section \<open> Function.thy \<close>

theory Function
  imports Main
begin

(* Types *)

record ('x, 'y) RawFunction =
  raw_cod :: "'y set"
  raw_func :: "('x \<times> 'y) set"

definition raw_dom :: "('x, 'y) RawFunction \<Rightarrow> 'x set" where
 "raw_dom rf \<equiv> {x. \<exists>y. (x, y) \<in> raw_func rf}"

definition valid_map :: "('x, 'y) RawFunction \<Rightarrow> bool" where
"valid_map rf \<equiv>
  let
      welldefined = (\<forall>x y. (x, y) \<in> raw_func rf \<longrightarrow> x \<in> raw_dom rf\<and> y \<in> raw_cod rf);
      deterministic = (\<forall>x y y'. (x, y) \<in> raw_func rf \<and> (x, y') \<in> raw_func rf \<longrightarrow> y = y');
      total = (\<forall>x. x \<in> raw_dom rf \<longrightarrow> (\<exists>y. (x, y) \<in> raw_func rf))

  in welldefined \<and> deterministic \<and> total"

typedef ('x, 'y) Function = "{ rf :: ('x, 'y) RawFunction . valid_map rf}"
proof
  define "empty_function" where "empty_function = \<lparr> raw_cod = {}, raw_func = {} \<rparr>"
  have "valid_map empty_function"
    by (simp add: empty_function_def valid_map_def raw_dom_def)
  thus "empty_function \<in> {rf. valid_map rf}" by auto
qed

(* find_theorems Abs_Function Rep_Function*)

setup_lifting type_definition_Function (* This warning is apparently not a problem. *)

lift_definition cod :: "('x, 'y) Function \<Rightarrow> 'y set" is raw_cod done

lift_definition func :: "('x, 'y) Function \<Rightarrow> ('x \<times> 'y) set" is raw_func done

lift_definition dom :: "('x, 'y) Function \<Rightarrow> 'x set" is raw_dom done

(* Validity *)

lemma welldefined_dom : "(x, y) \<in> func f \<Longrightarrow> x \<in> dom f"
  using dom.rep_eq func.rep_eq raw_dom_def by fastforce

lemma welldefined_cod : "(x, y) \<in> func f \<Longrightarrow> y \<in> cod f"
  by (transfer, simp add: valid_map_def)

lemma welldefined : "(x, y) \<in> func f \<Longrightarrow> x \<in> dom f \<and> y \<in> cod f"
  by (simp add: welldefined_cod welldefined_dom)

lemma deterministic : "(x, y) \<in> func f \<Longrightarrow> (x, y') \<in> func f \<Longrightarrow> y = y'"
  using Rep_Function func.rep_eq valid_map_def by fastforce

lemma total : " x \<in> dom f \<Longrightarrow> \<exists>y. (x, y) \<in> func f"
  by (simp add: dom.rep_eq func.rep_eq raw_dom_def)

lemma valid_mapI [intro] : "((\<And>x y. (x, y) \<in> raw_func rf \<Longrightarrow>  x \<in> raw_dom rf \<and> y \<in> raw_cod rf) \<Longrightarrow>
                   (\<And>x y y'. (x, y) \<in> raw_func rf \<Longrightarrow> (x, y') \<in> raw_func rf \<Longrightarrow> y = y') \<Longrightarrow>
                   (\<And>x. x \<in> raw_dom rf \<Longrightarrow> (\<exists>y. (x, y) \<in> raw_func rf))
                   \<Longrightarrow> valid_map rf) "
  by (metis valid_map_def)

(* Function application *)

definition "Function_app_undefined_arg_not_in_domain _ \<equiv> undefined"

definition raw_app :: "('x, 'y) RawFunction \<Rightarrow> 'x \<Rightarrow> 'y"  where
"raw_app rf x \<equiv>
   if x \<in> raw_dom rf
   then  (THE y. (x, y) \<in> raw_func rf)
  else Function_app_undefined_arg_not_in_domain x"

lift_definition app :: "('x, 'y) Function \<Rightarrow> 'x \<Rightarrow> 'y" (infixr "\<cdot>" 998) is "raw_app"  done

lemma fun_app : "x \<in> dom f \<Longrightarrow> (x, f \<cdot> x) \<in> func f"
  apply transfer
  by (smt (verit) raw_app_def the_equality valid_map_def)

lemma fun_app2 : "x \<in> dom f \<Longrightarrow> f \<cdot> x  \<in> cod f"
  by (meson fun_app welldefined)

lemma fun_app3 [simp] : "x \<in> dom f \<Longrightarrow> f \<cdot> x = (THE y. (x, y) \<in> func f) "
  by (metis deterministic fun_app the_equality)

lemma fun_ext : "dom f = dom g \<Longrightarrow> cod f = cod g \<Longrightarrow> (\<And>x. x \<in> dom f \<Longrightarrow> f \<cdot> x = g \<cdot> x) \<Longrightarrow> func f = func g"
  unfolding  dom_def
  apply (simp_all add: Let_def, auto)
  apply (metis deterministic dom.rep_eq fun_app welldefined)
  by (metis deterministic dom.rep_eq fun_app welldefined)

lemma fun_ext2 : "dom f = dom g \<Longrightarrow> cod f = cod g \<Longrightarrow> (\<And>x. x \<in> dom f \<Longrightarrow> f \<cdot> x = g \<cdot> x) \<Longrightarrow> f = g"
  apply (transfer, simp)
  by (metis (full_types) Abs_Function_inverse CollectI app.rep_eq cod.rep_eq dom.rep_eq equality fun_ext func.rep_eq old.unit.exhaust)

lemma fun_app_iff  : "(x, y) \<in> func f \<Longrightarrow> (f \<cdot> x) = y"
  by (meson fun_app deterministic welldefined)

(* Properties *)

abbreviation is_surjective :: "('x, 'y) Function \<Rightarrow> bool" where
"is_surjective f \<equiv> \<forall> y . y \<in> cod f \<longrightarrow> (\<exists> x . x \<in> dom f \<and> f \<cdot> x = y)"

abbreviation is_injective :: "('x, 'y) Function \<Rightarrow> bool" where
"is_injective f \<equiv> \<forall>x x' . x \<in> dom f \<longrightarrow> x' \<in> dom f \<longrightarrow> f \<cdot> x = f \<cdot> x' \<longrightarrow> x = x'"

abbreviation is_bijective :: "('x, 'y) Function \<Rightarrow> bool" where
"is_bijective f \<equiv> is_surjective f \<and> is_injective f"

(* Composition of functions *)

definition "Function_compose_undefined_incomposable _ _ \<equiv> undefined"

definition raw_compose :: "('y, 'z) RawFunction \<Rightarrow> ('x, 'y) RawFunction \<Rightarrow> ('x, 'z) RawFunction" where
  "raw_compose rg rf \<equiv>
    if raw_dom rg = raw_cod rf
    then \<lparr> raw_cod = raw_cod rg, raw_func = relcomp (raw_func rf) (raw_func rg) \<rparr>
    else Rep_Function (Function_compose_undefined_incomposable rg rf)"

lift_definition compose :: "('y, 'z) Function \<Rightarrow> ('x, 'y) Function \<Rightarrow> ('x, 'z) Function" (infixl "\<bullet>"
    55) is raw_compose
proof (intro valid_mapI conjI, goal_cases)
  case (1 g f x y)
  then show ?case
    using raw_dom_def by fastforce
next
  case (2 g f x y)
  then show ?case
    by (metis cod.rep_eq func.rep_eq raw_compose_def relcompEpair select_convs(1) select_convs(2) valid_map_def welldefined_cod)
next
  case (3 g f x y y')
  then show ?case
    by (metis (no_types, opaque_lifting) fun_app_iff func.rep_eq raw_compose_def relcompEpair select_convs(2) valid_map_def)
next
  case (4 g f x)
  then show ?case
    by (simp add: raw_dom_def)
qed

lemma compose_welldefined_cod : "dom g = cod f \<Longrightarrow> (x, y) \<in> func (g \<bullet> f) \<Longrightarrow> y \<in> cod g"
  by (metis (no_types) cod.rep_eq compose.rep_eq dom.rep_eq func.rep_eq raw_compose_def select_convs(1) welldefined_cod)

lemma compose_welldefined_dom : "dom g = cod f \<Longrightarrow> (x, y) \<in> func (g \<bullet> f) \<Longrightarrow> x \<in> dom f"
  apply transfer
  by (metis raw_compose_def relcomp.cases select_convs(2) valid_map_def)

lemma compose_welldefined : "dom g = cod f \<Longrightarrow> (x, y) \<in> func (g \<bullet> f) \<Longrightarrow> x \<in> dom f \<and> y \<in> cod g"
  by (simp add: compose_welldefined_cod compose_welldefined_dom)

lemma compose_deterministic : "dom g = cod f \<Longrightarrow> (x, y) \<in> func (g \<bullet> f) \<Longrightarrow> (x, y') \<in> func (g \<bullet> f) \<Longrightarrow> y = y'"
  by (simp add: deterministic)

lemma compose_total : "dom g = cod f \<Longrightarrow> x \<in> dom f \<Longrightarrow> \<exists>y. (x, y) \<in> func (g \<bullet> f)"
  apply transfer
  by (metis (no_types, lifting) raw_compose_def relcomp.simps select_convs(2) valid_map_def)

lemma cod_compose [simp] : "dom g = cod f \<Longrightarrow> cod (g \<bullet> f) = cod g"
  by (transfer, simp add: raw_compose_def)

lemma dom_compose [simp] : "dom g = cod f \<Longrightarrow> dom (g \<bullet> f) = dom f"
  apply transfer
  by (smt (verit) Collect_cong raw_compose_def raw_dom_def relcomp.simps select_convs(2) valid_map_def)

lemma compose_assoc : "dom h = cod g \<Longrightarrow> dom g = cod f \<Longrightarrow> (h \<bullet> g) \<bullet> f = h \<bullet> (g \<bullet> f)"
  apply (transfer, simp_all add: raw_dom_def valid_map_def raw_compose_def)
  apply (safe, blast, blast, blast)
  by (smt (verit) mem_Collect_eq relcomp.simps)

lemma compose_app [simp] : "(x, y) \<in> func f \<Longrightarrow> dom g = cod f \<Longrightarrow> (y, z) \<in> func g
 \<Longrightarrow> (g \<bullet> f) \<cdot> x = z"
  apply (rule fun_app_iff, transfer)
  by (simp add: raw_compose_def relcomp.relcompI)

lemma compose_app_assoc : "x \<in> dom f \<Longrightarrow> dom g = cod f \<Longrightarrow> (g \<bullet> f) \<cdot> x = g \<cdot> (f \<cdot> x)"
  apply transfer
  unfolding valid_map_def raw_dom_def raw_compose_def raw_app_def
  apply (simp add: Let_def,safe)
     apply (smt (verit, best) relcomp.simps the_equality)
    apply (metis (mono_tags, lifting) theI_unique)
  apply (meson relcomp.relcompI)
  by (metis Function_app_undefined_arg_not_in_domain_def)

lemma surjection_is_right_cancellative : "is_surjective f \<Longrightarrow> cod f = dom g \<Longrightarrow> cod f = dom h
 \<Longrightarrow> g \<bullet> f = h \<bullet> f \<Longrightarrow> g = h"
  by (metis cod_compose compose_app_assoc fun_ext2)

lemma injection_is_left_cancellative : "is_injective f \<Longrightarrow> cod g = dom f \<Longrightarrow> cod h = dom f
 \<Longrightarrow> f \<bullet> g = f \<bullet> h \<Longrightarrow> g = h"
  by (metis compose_app_assoc dom_compose fun_app2 fun_ext2)

(* Identity functions *)

definition raw_ident :: "'x set \<Rightarrow> ('x, 'x) RawFunction" where
"raw_ident X \<equiv>  \<lparr> raw_cod = X, raw_func = Id_on X \<rparr>"

lift_definition ident :: "'x set \<Rightarrow> ('x, 'x) Function" is raw_ident
  by (simp add: Id_on_iff raw_dom_def raw_ident_def valid_map_def)

lemma ident_dom [simp] : "dom (ident X) = X"
  by (transfer, simp add: Id_on_iff raw_dom_def raw_ident_def)

lemma ident_cod [simp] : "cod (ident X) = X"
  by (transfer, simp add: raw_ident_def)

lemma ident_app [simp] : "x \<in> X \<Longrightarrow> ident X \<cdot> x = x"
  by (transfer, metis Id_onI app.rep_eq fun_app_iff func.rep_eq ident.rep_eq raw_ident_def select_convs(2))

lemma compose_ident_left [simp] : "ident (cod f) \<bullet> f = f"
  by (smt (verit, ccfv_SIG) cod_compose compose_app_assoc dom_compose fun_app2 fun_ext2 ident_app ident_cod ident_dom)

lemma compose_ident_right [simp] : "f \<bullet> ident (dom f) = f"
  by (smt (verit, ccfv_SIG) cod_compose compose_app_assoc dom_compose fun_app2 fun_ext2 ident_app ident_cod ident_dom)

(* Constant functions *)

definition "Function_const_undefined_arg_not_in_codomain _ \<equiv> undefined"

definition raw_const :: "'x set \<Rightarrow>  'y set  \<Rightarrow> 'y \<Rightarrow>  ('x, 'y) RawFunction" where
"raw_const X Y y \<equiv>
  if y \<in> Y
  then \<lparr> raw_cod = Y, raw_func = { (x, y) | x. x \<in> X }\<rparr>
  else Rep_Function (Function_const_undefined_arg_not_in_codomain y)"

lift_definition const :: "'x set \<Rightarrow>  'y set  \<Rightarrow> 'y \<Rightarrow> ('x, 'y) Function" is raw_const
proof (intro valid_mapI, goal_cases)
  case (1 X Y y x ya)
  then show ?case
    by (smt (verit) cod.rep_eq func.rep_eq mem_Collect_eq raw_const_def raw_dom_def select_convs(1) select_convs(2) snd_conv welldefined)
next
  case (2 X Y y x ya y')
  then show ?case
    by (smt (verit, ccfv_SIG) CollectD deterministic func.rep_eq raw_const_def select_convs(2) snd_conv)
next
  case (3 X Y y x)
  then show ?case
    by (simp add: raw_dom_def)
qed

lemma const_dom [simp] : "y \<in> Y \<Longrightarrow> dom (const X Y y) = X"
  by (transfer, simp add: raw_const_def raw_dom_def)

lemma const_cod [simp] : "y \<in> Y \<Longrightarrow> cod (const X Y y) = Y"
  by (transfer, simp add: raw_const_def)

lemma const_app [simp] : "x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> (const X Y y) \<cdot> x = y"
  apply transfer
  by (smt (verit, best) CollectD app.rep_eq const.rep_eq const_dom fun_app func.rep_eq raw_const_def select_convs(2) snd_conv)

lemma const_func : "y \<in> Y \<Longrightarrow> func (const X Y y) = {(x, y) | x . x \<in> X }"
  by (transfer, simp add: raw_const_def)

end


theory Subsystems
  imports  Linear_Inequalities.Decomposition_Theorem
    Jordan_Normal_Form.DL_Rank_Submatrix

begin

definition sub_system where
  "sub_system A b I \<equiv> (submatrix A I UNIV,  vec_of_list (nths (list_of_vec b) I))"

lemma sub_system_fst:
  shows "fst (sub_system A b I) = submatrix A I UNIV"
  unfolding sub_system_def
  by force

lemma sub_system_snd:
  shows "snd (sub_system A b I) = vec_of_list (nths (list_of_vec b) I)"
  unfolding sub_system_def
  by force

lemma dim_row_subsyst_mat:
  shows "dim_row (fst (sub_system A b I)) = card {i. i < dim_row A \<and> i \<in> I}"
  using dim_submatrix(1)[of A I UNIV] sub_system_fst by metis

lemma dim_col_submatrix_UNIV:
  shows "dim_col (submatrix A I UNIV) = dim_col A"
  using dim_submatrix(2)[of A I UNIV]
  by fastforce

lemma dim_col_subsyst_mat:
  shows "dim_col (fst (sub_system A b I)) = dim_col A"
  using dim_col_submatrix_UNIV
  by (metis sub_system_fst)

lemma dim_row_less_card_I:
  assumes "finite I"
  shows "dim_row (fst (sub_system A b I)) \<le> card I"
proof -
  have "{i. i < dim_row A \<and> i \<in> I} \<subseteq> I" by auto
  then have "card {i. i < dim_row A \<and> i \<in> I} \<le> card I"
    using assms card_mono by blast
  then show ?thesis
    using dim_row_subsyst_mat by metis
qed

lemma dim_subsyst_vec:
  shows "dim_vec (snd (sub_system A b I)) = card {i. i < dim_vec b \<and> i \<in> I}"
proof -
  have "length (list_of_vec b) = dim_vec b"
    using Matrix.length_list_of_vec  carrier_vecD by blast
  then show ?thesis
    using sub_system_snd length_nths
    by (metis Matrix.length_list_of_vec list_of_vec_vec_of_list)
qed

lemma  dim_subsyst_vec_less_b:
  shows "dim_vec (snd (sub_system A b I)) \<le> dim_vec b"
proof -
  have "{i. i < dim_vec b \<and> i \<in> I} \<subseteq> {0..<dim_vec b}" by auto
  then have "card {i. i < dim_vec b \<and> i \<in> I} \<le> card  {0..<dim_vec b}"
    by (metis card_mono finite_atLeastLessThan)
  then show ?thesis
    by (metis card_atLeastLessThan diff_zero dim_subsyst_vec)
qed

lemma  dim_subsyst_mat_less_A:
  shows "dim_row (fst (sub_system A b I)) \<le> dim_row A"
proof -
  have "{i. i < dim_row A \<and> i \<in> I} \<subseteq> {0..<dim_row A}" by auto
  then have "card {i. i < dim_row A \<and> i \<in> I} \<le> card  {0..<dim_row A}"
    by (metis card_mono finite_atLeastLessThan)
  then show ?thesis
    by (metis card_atLeastLessThan diff_zero dim_row_subsyst_mat)
qed

lemma dims_subsyst_same:
  assumes "dim_row A = dim_vec b"
  shows "dim_row (fst (sub_system A b I)) = dim_vec (snd (sub_system A b I))"
  by (metis  assms dim_row_subsyst_mat dim_subsyst_vec)

lemma dims_subsyst_same':
  assumes "dim_row A = dim_vec b"
  assumes "(A', b') = (sub_system A b I)"
  shows "dim_row A' = dim_vec b'"
  using dims_subsyst_same assms
  by (metis fst_conv snd_conv)

lemma dims_subsyst_same_carr:
  assumes "A \<in> carrier_mat nr n"
  assumes "b \<in> carrier_vec nr"
  assumes "(A', b') = (sub_system A b I)"
  shows "dim_row A' = dim_vec b'"
  by (metis assms carrier_matD(1) carrier_vecD dims_subsyst_same')

lemma I_subsys_same_card:
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  assumes "I \<subseteq> {0..<nr}"
  shows "dim_row (fst (sub_system A b I)) = card I"
    "dim_vec (snd (sub_system A b I)) = card I"
proof -
  have "{i. i < nr \<and> i \<in> I} = I" using assms(3) by auto
  then have " card {i. i < dim_row A \<and> i \<in> I} = card I" using A by auto
  then show "dim_row (fst (sub_system A b I)) = card I" using dim_row_subsyst_mat by metis
  then show "dim_vec (snd (sub_system A b I)) = card I" using b
    by (simp add: \<open>{i. i < nr \<and> i \<in> I} = I\<close> dim_subsyst_vec)
qed

lemma carrier_mat_subsyst:
  assumes "dim_row A = dim_vec b"
  shows "(fst (sub_system A b I)) \<in> carrier_mat (dim_row (fst (sub_system A b I))) (dim_col A)"
  using dim_col_subsyst_mat by blast

lemma subsyst_rows_carr:
  assumes "A \<in> carrier_mat nr n"
  shows "set (rows (submatrix A I UNIV)) \<subseteq> carrier_vec n"
  by (metis assms dim_col_submatrix_UNIV carrier_matD(2) rows_carrier)

lemma nths_list_pick_vec_same:
  shows "vec_of_list (nths (list_of_vec b) I) =
    vec (card {i. i<dim_vec b \<and> i\<in>I})  (\<lambda> i. b $ (pick I i))"
  by (smt (verit, best) Collect_cong Matrix.dim_vec_of_list Matrix.length_list_of_vec
      dim_vec eq_vecI index_vec length_nths list_of_vec_index nth_nths vec_of_list_index)

lemma subsyst_b_i:
  assumes "i < dim_vec (snd (sub_system A b I))"
  shows "(snd (sub_system A b I)) $ i = b $ (pick I i)"
  using nths_list_pick_vec_same sub_system_snd
  by (metis (no_types, lifting) assms dim_subsyst_vec index_vec)

lemma nths_UNIV_same:
  "nths xs UNIV = xs"
  unfolding nths_def
  using filter_True by auto

lemma itself_is_subsyst:
  shows "(A, b) = sub_system A b UNIV"
proof
  have "A = submatrix A UNIV UNIV"
    apply rule
      apply (simp add: dim_submatrix(1) dim_submatrix(2) pick_UNIV submatrix_index)
     apply (fastforce simp: dim_submatrix(1))
    apply (fastforce simp: dim_submatrix(2))
    done
  then show "fst (A, b) = fst (sub_system A b UNIV)"
    by (metis fst_eqD sub_system_fst)
  show "snd (A, b) = snd (sub_system A b UNIV)"
    by (metis snd_eqD nths_UNIV_same vec_list sub_system_snd)
qed

lemma pick_index_row_in_A:
  assumes "j < dim_row (fst (sub_system A b I))"
  shows "row (fst (sub_system A b I)) j = row A (pick I j)"
  using row_submatrix_UNIV[of j A I]
  by (metis assms dim_row_subsyst_mat sub_system_fst)

lemma exist_index_in_A:
  assumes "dim_row A = dim_vec b"
  assumes "j < dim_vec (snd (sub_system A b I))"
  shows "\<exists> i < dim_vec b. i \<in> I \<and> row (fst (sub_system A b I)) j = row A i
          \<and> (snd (sub_system A b I)) $ j = b $ i \<and> i = pick I j"
proof -
  have "(pick I j) < dim_vec b"
    by (metis assms(2)  dim_subsyst_vec pick_le)
  moreover have "(pick I j) \<in> I"
    apply(cases "finite I")
     apply (metis (mono_tags, lifting) assms dim_row_less_card_I dims_subsyst_same
        order_less_le_trans pick_in_set_le)
    using pick_in_set_inf by auto
  ultimately show ?thesis
    using  assms dims_subsyst_same pick_index_row_in_A subsyst_b_i
    by metis
qed

lemma exist_index_in_A_carr:
  assumes "A \<in> carrier_mat nr n"
  assumes "b \<in> carrier_vec nr"
  assumes "(C, d) = sub_system A b I"
  assumes "j < dim_row C"
  shows "\<exists> i < nr. i \<in> I \<and> row C j = row A i
          \<and> d $ j = b $ i \<and> i = pick I j"
  by (metis assms carrier_matD(1) carrier_vecD dims_subsyst_same_carr
      exist_index_in_A fst_conv snd_conv)

lemma card_of_smaller_is_index_in_subsystem:
  assumes "j < dim_vec b"
  assumes "j \<in> I"
  shows "card {a\<in>I. a < j} < dim_vec (snd (sub_system A b I))"
proof -
  let ?i = "card {a\<in>I. a < j}"
  have "pick I ?i = j" using pick_card_in_set assms(2) by auto
  have "dim_vec (snd (sub_system A b I)) = card {i. i < dim_vec b \<and> i \<in> I}"
    by (metis dim_subsyst_vec)
  have "j \<notin> {a\<in>I. a < j} \<and> j \<in> {i. i < dim_vec b \<and> i \<in> I}" using assms(1-2) by auto
  then  have "{a\<in>I. a < j} \<subset> {i. i < dim_vec b \<and> i \<in> I}"
    by auto
  then have "?i < card {i. i < dim_vec b \<and> i \<in> I}"
    by (simp add: psubset_card_mono)
  then show "?i <  dim_vec (snd (sub_system A b I))"
    using \<open>dim_vec (snd (sub_system A b I)) = card {i. i < dim_vec b \<and> i \<in> I}\<close> by presburger
qed

lemma exist_index_in_A':
  assumes "dim_row A = dim_vec b"
  assumes "j < dim_vec b"
  assumes "j \<in> I"
  shows " \<exists> i < dim_vec (snd (sub_system A b I)).
       row (fst (sub_system A b I)) i = row A j \<and> (snd (sub_system A b I)) $ i = b $ j"
proof -
  let ?A' = "(fst (sub_system A b I))"
  let ?b' = "(snd (sub_system A b I))"
  let ?i = "card {a\<in>I. a < j}"

  have pick_of_I: "pick I ?i = j"
    using assms(3) pick_card_in_set by presburger
  have  index: "?i <  dim_vec ?b'"
    using card_of_smaller_is_index_in_subsystem assms(2-3) by blast
  then have "row ?A' ?i = row A j"
    by (simp add: assms(1) dims_subsyst_same index pick_index_row_in_A pick_of_I)
  moreover have "?b' $ ?i= b $ j"
    by (simp add: index pick_of_I subsyst_b_i)
  ultimately show ?thesis
    using index by blast
qed

lemma subsystem_fulfills_P:
  assumes "dim_row A = dim_vec b"
  assumes "(A', b') = sub_system A b I"
  assumes "\<forall> i < dim_row A'. P (row A' i) (b' $ i)"
  shows "\<forall>i \<in> I \<inter> {0..<dim_row A}. P (row A i) (b $ i)"
proof
  fix i
  assume "i \<in> I \<inter> {0..<dim_row A}"
  have "dim_row A' = dim_vec b'" using assms(1)
    by (metis assms(2) dims_subsyst_same prod.sel(1) prod.sel(2))
  then obtain j where "j<dim_row A' \<and> row A' j = row A i \<and> b' $ j = b $ i"
    using exist_index_in_A'[of A b i I]  assms(1-2)
    by (metis IntD1 IntD2 \<open>i \<in> I \<inter> {0..<dim_row A}\<close> atLeastLessThan_iff fst_conv snd_conv)
  then show "P (row A i) (b $ i)" using assms(3) by auto
qed

lemma subsystem_fulfills_P':
  assumes "dim_row A = dim_vec b"
  assumes "(A', b') = sub_system A b I"
  assumes "\<forall>i \<in> I \<inter> {0..<dim_row A}. P (row A i) (b $ i)"
  shows "\<forall> i < dim_row A'. P (row A' i) (b' $ i)"
proof(rule)+
  fix i
  assume "i < dim_row A'"
  have "dim_row A' = dim_vec b'" using assms(1)
    by (metis assms(2) dims_subsyst_same prod.sel(1) prod.sel(2))
  then obtain j where "j \<in> I \<and> j <dim_row A \<and> (row A j) = (row A' i) \<and> b $ j = b' $ i"
    using exist_index_in_A[of A b i] assms(1-2) `i < dim_row A'`
    by (metis fst_conv snd_conv)
  then have "P (row A j) (b $ j)" using assms(3)
    by (metis Int_iff atLeastLessThan_iff zero_le)
  then show " P (row A' i) (b' $ i)"
    by (simp add: \<open>j \<in> I \<and> j < dim_row A \<and> row A j = row A' i \<and> b $ j = b' $ i\<close>)
qed

lemma insert_elem_sub_system_fulfills_P:
  assumes "dim_row A = dim_vec b"
  assumes "i < dim_vec b"
  assumes "(A', b') = sub_system A b I"
  assumes "(A'', b'') = sub_system A b (I \<union> {i})"
  shows "(\<forall> i < dim_row A''. P (row A'' i) (b'' $ i)) \<longleftrightarrow>
         (\<forall> j < dim_row A'. P (row A' j) (b' $ j)) \<and> P (row A i) (b $ i)"
    (is "?P_A'' \<longleftrightarrow> ?P_A'")
proof
  show "?P_A'' \<Longrightarrow> ?P_A'"
  proof -
    assume "?P_A''"
    then have "\<forall>i \<in> (I \<union> {i}) \<inter> {0..<dim_row A}. P (row A i) (b $ i)"
      using subsystem_fulfills_P  assms(1) assms(4) by blast
    then show "?P_A'"
      using subsystem_fulfills_P'[of A b A' b' I P]
      by (metis Int_iff assms(1-3) atLeastLessThan_iff insert_iff insert_union le_less_linear
          less_nat_zero_code)
  qed
  show "?P_A' \<Longrightarrow> ?P_A''"
  proof -
    assume "?P_A'"
    then have "\<forall>i \<in> (I \<union> {i}) \<inter> {0..<dim_row A}. P (row A i) (b $ i)"
      using subsystem_fulfills_P  assms(1) assms(3) by blast
    then show "?P_A''"
      using subsystem_fulfills_P'
      using assms(1) assms(4) by blast
  qed
qed

lemma eq_for_all_index_then_eq:
  assumes "dim_row A = dim_vec b"
  assumes "\<forall>i<dim_row A. row A i \<bullet> x = b $ i"
  shows "A *\<^sub>v x = b"
  unfolding mult_mat_vec_def
  by (simp add: assms(1) assms(2) eq_vecI)

lemma leq_for_all_index_then_eq:
  assumes "dim_row A = dim_vec b"
  assumes "\<forall>i<dim_row A. row A i \<bullet> x \<le> b $ i"
  shows "A *\<^sub>v x \<le> b"
  unfolding mult_mat_vec_def
  by (simp add: assms(1) assms(2) less_eq_vec_def)

lemma insert_sub_system_eq:
  assumes "dim_row A = dim_vec b"
  assumes "i < dim_vec b"
  assumes "(A', b') = sub_system A b I"
  assumes "(A'', b'') = sub_system A b (I \<union> {i})"
  shows "{x. A'' *\<^sub>v x = b''} = {x. A' *\<^sub>v x = b' \<and> row A i \<bullet> x = b $ i}"
proof -
  have "\<forall>x.  A'' *\<^sub>v x = b'' \<longleftrightarrow>  A' *\<^sub>v x = b' \<and> row A i \<bullet> x = b $ i"
  proof
    fix x
    have "(\<forall>i<dim_row A''. row A'' i \<bullet> x = b'' $ i) =
    ((\<forall>j<dim_row A'. row A' j \<bullet> x = b' $ j) \<and> row A i \<bullet> x = b $ i)"
      using insert_elem_sub_system_fulfills_P[of A b i A' b' I A'' b'' "(\<lambda> r y.   r \<bullet> x = y)"]
        assms by fast
    then show "A'' *\<^sub>v x = b'' \<longleftrightarrow>  A' *\<^sub>v x = b' \<and> row A i \<bullet> x = b $ i"
      using eq_for_all_index_then_eq
      by (metis dims_subsyst_same' assms(1) assms(3-4) index_mult_mat_vec)
  qed
  then show ?thesis by presburger
qed

lemma insert_sub_system_leq:
  assumes "dim_row A = dim_vec b"
  assumes "i < dim_vec b"
  assumes "(A', b') = sub_system A b I"
  assumes "(A'', b'') = sub_system A b (I \<union> {i})"
  shows "{x. A'' *\<^sub>v x \<le> b''} = {x. A' *\<^sub>v x \<le> b' \<and> row A i \<bullet> x \<le> b $ i}"
proof -
  have "\<forall>x.  A'' *\<^sub>v x \<le> b'' \<longleftrightarrow>  A' *\<^sub>v x \<le> b' \<and> row A i \<bullet> x \<le> b $ i"
  proof
    fix x
    have "(\<forall>i<dim_row A''. row A'' i \<bullet> x \<le> b'' $ i) =
    ((\<forall>j<dim_row A'. row A' j \<bullet> x \<le> b' $ j) \<and> row A i \<bullet> x \<le> b $ i)"
      using insert_elem_sub_system_fulfills_P[of A b i A' b' I A'' b'' "(\<lambda> r y.   r \<bullet> x \<le> y)"]
        assms by fast
    then show "A'' *\<^sub>v x \<le> b'' \<longleftrightarrow>  A' *\<^sub>v x \<le> b' \<and> row A i \<bullet> x \<le> b $ i"
      using leq_for_all_index_then_eq
      by (metis assms(1) assms(3-4) dims_subsyst_same' index_mult_mat_vec less_eq_vec_def)
  qed
  then show ?thesis by presburger
qed

lemma remove_index_sub_system:
  assumes "dim_row A = dim_vec b"
  assumes "i \<in> I"
  assumes "i < dim_vec b"
  assumes "(A', b') = sub_system A b I"
  assumes "(A'', b'') = sub_system A b (I - {i})"
  shows "{x. A' *\<^sub>v x \<le> b'} = {x. A'' *\<^sub>v x \<le> b'' \<and> row A i \<bullet> x \<le> b $ i}"
proof -
  have "i \<notin> (I - {i})" using assms(2) by auto
  moreover have "I = (I - {i}) \<union> {i}" using assms(2) by auto
  ultimately show ?thesis
    using insert_sub_system_leq[of A b i  A'' b'' "I - {i}" A' b'] assms(1) assms(3-5)
    by argo
qed

lemma remove_index_sub_system_eq:
  assumes "dim_row A = dim_vec b"
  assumes "i \<in> I"
  assumes "i < dim_vec b"
  assumes "(A', b') = sub_system A b I"
  assumes "(A'', b'') = sub_system A b (I - {i})"
  shows "{x. A' *\<^sub>v x = b'} = {x. A'' *\<^sub>v x = b'' \<and> row A i \<bullet> x = b $ i}"
proof -
  have "i \<notin> (I - {i})" using assms(2) by auto
  moreover have "I = (I - {i}) \<union> {i}" using assms(2) by auto
  ultimately show ?thesis
    using insert_sub_system_eq[of A b i  A'' b'' "I - {i}" A' b'] assms(1) assms(3-5)
    by argo
qed

lemma remove_index_remove_row:
  assumes "dim_row A = dim_vec b"
  assumes "i \<in> I"
  assumes "i < dim_vec b"
  assumes "(A', b') = sub_system A b I"
  assumes "(C, d) = sub_system A b (I - {i})"
  assumes "row A i \<notin> set (rows C)"
  shows "set (rows C) = set (rows A') - {row A i}"
proof(safe)
  {
    fix r
    assume "r \<in> set (rows C)"
    then obtain j' where j': "j' < dim_row C \<and> row C j' = r"
      by (metis in_set_conv_nth length_rows nth_rows)
    obtain i' where i:"i' < dim_row A \<and> i' \<in> (I - {i}) \<and> row A i' = row C j' \<and> d $ j' = b $ i'"
      using exist_index_in_A[of A b j' "I - {i}"]
        dims_subsyst_same' fst_conv j' snd_conv
      by (metis assms(1) assms(5))
    then obtain j where j: "j < dim_row A' \<and> row A' j = row A i'"
      using exist_index_in_A'[of A b i' I]
      by (metis Diff_iff assms(1) assms(4) dims_subsyst_same fst_conv)
    then show "r \<in> set (rows A')"
      by (metis i in_set_conv_nth j' length_rows nth_rows)
  }
  show "\<And>x. row A i \<in> set (rows C) \<Longrightarrow> False" using assms(6) by auto

  fix r
  assume "r \<in> set (rows A')"
  assume "r \<notin> set (rows C)"
  then obtain j' where j': "j' < dim_row A' \<and> row A' j' = r" using `r \<in> set (rows A')`
    by (metis in_set_conv_nth length_rows nth_rows)
  obtain i' where i:"i' < dim_row A \<and> i' \<in> I \<and> row A i' = row A' j' \<and> b' $ j' = b $ i'"
    using exist_index_in_A[of A b j' "I"]
      dims_subsyst_same' fst_conv j' snd_conv
    by (metis assms(1) assms(4))
  show "r = row A i"
  proof(cases "i' \<in> (I - {i})")
    case True
    then obtain j where j: "j < dim_row C \<and> row C j = row A i'"
      using exist_index_in_A'[of A b i' "I - {i}"]
      by (metis assms(1) assms(5) dims_subsyst_same fst_conv i)
    then show ?thesis
      by (metis \<open>r \<notin> set (rows C)\<close> i in_set_conv_nth j' length_rows nth_rows)
  next
    case False
    then have "i' = i"
      using i by blast
    then show ?thesis
      using i j' by presburger
  qed
qed

lemma add_index_sub_system_dims:
  assumes "i \<notin> I"
  assumes "i < dim_vec b"
  assumes "(A', b') = sub_system A b I"
  assumes "(A'', b'') = sub_system A b (I \<union> {i})"
  shows "dim_vec b'' = dim_vec b' + 1"
proof -
  have 1:"dim_vec b' = card {i. i < dim_vec b \<and> i \<in> I}"
    using dim_subsyst_vec using assms(3)
    by (metis snd_conv)
  have "{i. i < dim_vec b \<and> i \<in> I} = {i. i < dim_vec b} \<inter> I" by auto
  have 2:"dim_vec b'' = card {j. j < dim_vec b \<and> j \<in> (I \<union> {i})}"
    using dim_subsyst_vec using assms(4)
    by (metis snd_conv)
  then have "{j. j < dim_vec b \<and> j \<in> (I \<union> {i})} =
      ({i. i < dim_vec b} \<inter> I) \<union> {i}" using assms(2) by auto
  then have "card {i. i < dim_vec b \<and> i \<in> I} + 1 = card {j. j < dim_vec b \<and> j \<in> (I \<union> {i})}"
    by (simp add: \<open>{i. i < dim_vec b \<and> i \<in> I} = {i. i < dim_vec b} \<inter> I\<close> assms(1))
  then show ?thesis
    using 1 2 by presburger
qed

lemma remove_index_sub_system_dims:
  assumes "i \<in> I"
  assumes "i < dim_vec b"
  assumes "(A', b') = sub_system A b I"
  assumes "(A'', b'') = sub_system A b (I - {i})"
  shows "dim_vec b' = dim_vec b'' + 1"
proof -
  have "i \<notin> (I - {i})" using assms(2) by auto
  moreover have "I = (I - {i}) \<union> {i}" using assms(1) by auto
  ultimately show ?thesis
    using add_index_sub_system_dims[of i "I - {i}" b A'' b'' A A' b'] assms(1-4)
    by argo
qed

lemma linear_comb_holds_eq:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes "A \<in> carrier_mat nr n"
  assumes "x \<in> carrier_vec n"
  assumes "y \<in> carrier_vec n"
  assumes "z \<in> carrier_vec n"
  assumes "A *\<^sub>v x = b"
  assumes "A *\<^sub>v y = b"
  assumes "z = l \<cdot>\<^sub>v x + (1 - l) \<cdot>\<^sub>v y"
  assumes "0 \<le> l \<and> l \<le> 1"
  shows "A *\<^sub>v z = b"
proof -
  have "A *\<^sub>v z = A *\<^sub>v (l \<cdot>\<^sub>v x) + A *\<^sub>v ((1 - l) \<cdot>\<^sub>v y)"
    using mult_add_distrib_mat_vec[of A nr n "l \<cdot>\<^sub>v x" "(1 - l) \<cdot>\<^sub>v y"]
    using assms(1) assms(2) assms(3) assms(7) smult_carrier_vec by blast
  also have "\<dots> = l \<cdot>\<^sub>v (A *\<^sub>v x) + (1 - l) \<cdot>\<^sub>v (A *\<^sub>v y)"
    using mult_mat_vec[of A]
    using assms(1) assms(2) assms(3) by presburger
  also have "\<dots> = l \<cdot>\<^sub>v b + (1 - l) \<cdot>\<^sub>v b"
    using assms(5) assms(6) by presburger
  finally show "A *\<^sub>v z = b"
    by (metis add_smult_distrib_vec assms(8) le_add_diff_inverse one_smult_vec)
qed

lemma multiply_by_zero_eq:
  fixes a :: "'a :: trivial_conjugatable_linordered_field vec"
  assumes "dim_vec a = dim_vec b"
  shows "0 \<cdot>\<^sub>v a = 0 \<cdot>\<^sub>v b"
  apply rule
   apply (simp add: assms)
  by (simp add: assms)

lemma linear_comb_holds_less_eq:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes "A \<in> carrier_mat nr n"
  assumes "x \<in> carrier_vec n"
  assumes "y \<in> carrier_vec n"
  assumes "z \<in> carrier_vec n"
  assumes "A *\<^sub>v x \<le> b"
  assumes "A *\<^sub>v y \<le> b"
  assumes "z = l \<cdot>\<^sub>v x + (1 - l) \<cdot>\<^sub>v y"
  assumes "0 \<le> l \<and> l \<le> 1"
  shows "A *\<^sub>v z \<le> b"
proof -
  have "l \<cdot>\<^sub>v (A *\<^sub>v x) \<le> l \<cdot>\<^sub>v b"
    apply (cases "l = 0")
     apply (metis multiply_by_zero_eq Orderings.order_eq_iff assms(5) less_eq_vec_def)
    by (smt (verit, del_insts) assms(5) assms(8) index_smult_vec(1) index_smult_vec(2)
        less_eq_vec_def mult_le_cancel_left_pos order_le_imp_less_or_eq)
  have "(1 - l) \<cdot>\<^sub>v (A *\<^sub>v y) \<le> (1 - l) \<cdot>\<^sub>v b"
    apply (cases "l = 0")
    using assms(6) apply force
    by (smt (verit, best) Orderings.order_eq_iff assms(6) assms(8) diff_gt_0_iff_gt
        diff_numeral_special(9) index_smult_vec(1) index_smult_vec(2) less_eq_vec_def
        mult_le_cancel_left_pos multiply_by_zero_eq order_le_imp_less_or_eq)
  have "A *\<^sub>v z \<le> A *\<^sub>v (l \<cdot>\<^sub>v x) + A *\<^sub>v ((1 - l) \<cdot>\<^sub>v y)"
    using mult_add_distrib_mat_vec[of A nr n "l \<cdot>\<^sub>v x" "(1 - l) \<cdot>\<^sub>v y"]
    using assms(1) assms(2) assms(3) assms(7) smult_carrier_vec
    by (metis dual_order.refl)
  also have "\<dots> = l \<cdot>\<^sub>v (A *\<^sub>v x) + (1 - l) \<cdot>\<^sub>v (A *\<^sub>v y)"
    using mult_mat_vec[of A]
    using assms(1) assms(2) assms(3) by presburger
  also have "\<dots> \<le> l \<cdot>\<^sub>v b + (1 - l) \<cdot>\<^sub>v b"
    using `l \<cdot>\<^sub>v (A *\<^sub>v x) \<le> l \<cdot>\<^sub>v b` `(1 - l) \<cdot>\<^sub>v (A *\<^sub>v y) \<le> (1 - l) \<cdot>\<^sub>v b`
    by (metis index_smult_vec(2) vec_add_mono)
  finally show "A *\<^sub>v z \<le> b"
    by (metis add_smult_distrib_vec assms(8) le_add_diff_inverse one_smult_vec)
qed

end


theory ex12
imports
  Complex_Main
  "HOL-Library.Multiset"
begin

type_synonym rank = nat
type_synonym snat = "rank list"
abbreviation invar :: "snat \<Rightarrow> bool" where "invar s \<equiv> sorted_wrt (<) s"
definition \<alpha> :: "snat \<Rightarrow> nat" where "\<alpha> s = sum_list (map ((^) 2 ) s)"

value "\<alpha> [2, 3]"

lemmas [simp] = sorted_wrt_append
fun carry :: "rank \<Rightarrow> snat \<Rightarrow> snat" where
  "carry r [] = [r]"
| "carry r (s#ss) = (if r < s then r # s # ss else carry (r + 1) ss)"

lemma carry_invar [simp]:
  assumes "invar rs"
  shows "invar (carry r rs)"
  using assms
  apply(induction rs arbitrary: r)
   apply auto
  done

lemma [simp]: "\<alpha> (s # ss) = 2^s + \<alpha> ss"
  by (auto simp: \<alpha>_def)

lemma [simp]: "\<alpha> (ss @ ss') = \<alpha> ss + \<alpha> ss'"
  by (induction ss) (auto simp: \<alpha>_def)

lemma carry_\<alpha>:
  assumes "invar rs"
  assumes "\<forall> r' \<in>set rs. r \<le>r'"
  shows "\<alpha> (carry r rs) = 2^r + \<alpha> rs"
  using assms
  apply (induction r rs rule: carry.induct)
  by (auto simp: Suc_leI)

definition inc :: "snat \<Rightarrow> snat" where
  "inc \<equiv> carry 0"

lemma inc_invar [simp]: "invar rs \<Longrightarrow> invar (inc rs)"
  by(simp add: inc_def)

lemma inc_\<alpha>[simp]: "invar rs \<Longrightarrow> \<alpha> (inc rs) = Suc (\<alpha> rs)"
  using carry_\<alpha>
  by(simp add: inc_def)

fun add :: "snat \<Rightarrow> snat \<Rightarrow> snat" where
  "add rs1 [] = rs1"
| "add [] rs2 = rs2"
| "add (r1#rs1) (r2#rs2) = (
    if r1 < r2 then r1 # add rs1 (r2#rs2) else
    if r2 < r1 then r2 # add (r1#rs1) rs2
    else carry (r1 + 1) (add rs1 rs2)
  )"

lemma carry_lbound: "r' \<in> set (carry r'' rs) \<Longrightarrow> \<forall>x\<in>set rs. r < x \<Longrightarrow> r < r'' \<Longrightarrow>
         r < r'"
  apply(induction r'' rs rule: carry.induct)
  by (auto split: if_splits)

lemma add_lbound: "r' \<in> set (add rs1 rs2) \<Longrightarrow> \<forall>x\<in>set rs1. r < x \<Longrightarrow> \<forall>x\<in>set rs2. r < x \<Longrightarrow>
         r < r'"
  apply(induction rs1 rs2 arbitrary: r' rule: add.induct)
  by (auto split: if_splits simp: carry_lbound)

lemma add_invar [simp]:
assumes "invar rs1"
assumes "invar rs2"
shows "invar (add rs1 rs2)"
  using assms
  apply(induction rs1 rs2 rule: add.induct)
  using add_lbound
    apply simp_all
   apply fastforce
  done

lemma add_\<alpha>[simp]:
  assumes "invar rs1"
  assumes "invar rs2"
  shows "\<alpha> (add rs1 rs2 ) = \<alpha> rs1 + \<alpha> rs2"
  using assms
  apply(induction rs1 rs2 rule: add.induct)
  using add_lbound
  by (auto simp: Suc_leI carry_\<alpha>)

lemma size_snat:
assumes "invar rs"
shows "2^length rs \<le> \<alpha> rs + 1"
proof-
  have "2^length rs =  sum ((^) (2::nat)) {0::nat..<length rs} + 1"
    using sum_power2[where k = "length rs"]
    by auto
  also have "... \<le> \<alpha> rs + 1"
    unfolding \<alpha>_def
    by (auto simp: sorted_wrt_less_sum_mono_lowerbound[OF _ assms(1)])
  finally show ?thesis
    .
qed

fun t_carry :: "rank \<Rightarrow> snat \<Rightarrow> nat" where
  "t_carry r [] = 1"
| "t_carry r (s#ss) = (if r < s then 1 else 1 + t_carry (r + 1) ss)"

definition t_inc :: "snat \<Rightarrow> nat" where
  "t_inc = t_carry 0"

lemma t_carry_bound_aux:
  shows "t_carry r rs \<le> length rs + 1"
  apply(induction r rs rule: t_carry.induct)
  by auto

lemma t_carry_bound:
  assumes "invar rs"
  shows "t_carry r rs \<le> log 2 (\<alpha> rs + 1 ) + 1"
proof-
  have "t_carry r rs \<le> length rs + 1"
    using t_carry_bound_aux .
  also have "... \<le> log 2 (\<alpha> rs + 1) + 1"
    using le_log2_of_power[OF size_snat[OF assms]]
    by auto
  finally show ?thesis
    using of_nat_le_iff
    by simp
qed

lemma t_inc_bound:
  assumes "invar rs"
  shows "t_inc rs \<le> log 2 (\<alpha> rs + 1 ) + 1"
  using t_carry_bound[OF assms]
  by (auto simp: t_inc_def)

fun t_add :: "snat \<Rightarrow> snat \<Rightarrow> nat" where
  "t_add rs1 [] = 1"
| "t_add [] rs2 = 1"
| "t_add (r1#rs1) (r2#rs2) = (
    if r1 < r2 then 1 + t_add rs1 (r2#rs2) else
    if r2 < r1 then 1 + t_add (r1#rs1) rs2
    else 1 + (t_add rs1 rs2) + (t_carry (r1 + 1) (add rs1 rs2))
  )"

lemma t_carry_tree_length:
  "t_carry r rs + length (carry r rs) = 2 + length rs"
by (induction r rs rule: carry.induct) auto

lemma t_add_length:
  "length (add rs1 rs2) + t_add rs1 rs2 \<le> 2 * (length rs1 + length rs2) + 1"
by (induction rs1 rs2 rule: t_add.induct)
   (auto simp: t_carry_tree_length algebra_simps)

lemma t_add_bound:
fixes rs1 rs2
defines "n1 \<equiv> \<alpha> rs1"
defines "n2 \<equiv> \<alpha> rs2"
assumes INVARS : "invar rs1" "invar rs2"
shows "t_add rs1 rs2 \<le> 4 *log 2 (n1 + n2 + 1 ) + 2"
proof-
  define n where "n = n1 + n2"

  from t_add_length[of rs1 rs2]
  have "t_add rs1 rs2 \<le> 2 * (length rs1 + length rs2) + 1" by auto
  hence "(2::nat)^t_add rs1 rs2 \<le> 2^(2 * (length rs1 + length rs2) + 1)"
    by (rule power_increasing) auto
  also have "\<dots> = 2*(2^length rs1)\<^sup>2*(2^length rs2)\<^sup>2"
    by (auto simp: algebra_simps power_add power_mult)
  also note size_snat[OF INVARS(1)]
  also note INVARS(2)[THEN size_snat]
  finally have "2 ^ t_add rs1 rs2 \<le> 2 * (n1 + 1)\<^sup>2 * (n2 + 1)\<^sup>2"
    by (auto simp: power2_nat_le_eq_le n1_def n2_def)
  from le_log2_of_power[OF this] have "t_add rs1 rs2 \<le> log 2 \<dots>"
    by simp
  also have "\<dots> = log 2 2 + 2*log 2 (n1 + 1) + 2*log 2 (n2 + 1)"
    by (simp add: log_mult log_nat_power)
  also have "n2 \<le> n" by (auto simp: n_def)
  finally have "t_add rs1 rs2 \<le> log 2 2 + 2*log 2 (n1 + 1) + 2*log 2 (n + 1)"
    by auto
  also have "n1 \<le> n" by (auto simp: n_def)
  finally have "t_add rs1 rs2 \<le> log 2 2 + 4*log 2 (n + 1)"
    by auto
  also have "log 2 2 \<le> 2" by auto
  finally have "t_add rs1 rs2 \<le> 4*log 2 (n + 1) + 2" by auto
  thus ?thesis unfolding n_def by (auto simp: algebra_simps)
qed

end


section\<open>The Delta System Lemma\label{sec:dsl}\<close>

theory Delta_System
  imports
    Cardinal_Library

begin

text\<open>The \<^emph>\<open>Delta System Lemma\<close> (DSL) states that any uncountable family of
finite sets includes an uncountable delta system. This is the simplest
non trivial version; others, for cardinals greater than \<^term>\<open>\<aleph>\<^bsub>1\<^esub>\<close>  assume
some weak versions of the generalized continuum hypothesis for the
cardinals involved.

The proof is essentially the one in \<^cite>\<open>\<open>III.2.6\<close> in "kunen2011set"\<close> for the
case  \<^term>\<open>\<aleph>\<^bsub>1\<^esub>\<close>; another similar presentation can be found in
\<^cite>\<open>\<open>Chap.~16\<close> in "JW"\<close>.\<close>

lemma delta_system_Aleph1:
  assumes "\<forall>A\<in>F. Finite(A)" "F \<approx> \<aleph>\<^bsub>1\<^esub>"
  shows "\<exists>D. D \<subseteq> F \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>"
proof -
  text\<open>Since all members are finite,\<close>
  from \<open>\<forall>A\<in>F. Finite(A)\<close>
  have "(\<lambda>A\<in>F. |A|) : F \<rightarrow> \<omega>" (is "?cards : _")
    by (rule_tac lam_type) simp
  moreover from this
  have a:"?cards -`` {n} = { A\<in>F . |A| = n }" for n
    using vimage_lam by auto
  moreover
  note \<open>F \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
  moreover from calculation
  text\<open>there are uncountably many have the same cardinal:\<close>
  obtain n where "n\<in>\<omega>" "|?cards -`` {n}| = \<aleph>\<^bsub>1\<^esub>"
    using eqpoll_Aleph1_cardinal_vimage[of F ?cards] by auto
  moreover
  define G where "G \<equiv> ?cards -`` {n}"
  moreover from calculation
  have "G \<subseteq> F" by auto
  ultimately
  text\<open>Therefore, without loss of generality, we can assume that all
  elements of the family have cardinality \<^term>\<open>n\<in>\<omega>\<close>.\<close>
  have "A\<in>G \<Longrightarrow> |A| = n" and "G \<approx> \<aleph>\<^bsub>1\<^esub>" for A
    using cardinal_Card_eqpoll_iff by auto
  with \<open>n\<in>\<omega>\<close>
  text\<open>So we prove the result by induction on this \<^term>\<open>n\<close> and
  generalizing \<^term>\<open>G\<close>, since the argument requires changing the
  family in order to apply the inductive hypothesis.\<close>
  have "\<exists>D. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>"
  proof (induct arbitrary:G)
    case 0 \<comment> \<open>This case is impossible\<close>
    then
    have "G \<subseteq> {0}"
      using cardinal_0_iff_0 by auto
    with \<open>G \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
    show ?case
      using nat_lt_Aleph1 subset_imp_le_cardinal[of G "{0}"]
        lt_trans2 cardinal_Card_eqpoll_iff by auto
  next
    case (succ n)
    then
    have "\<forall>a\<in>G. Finite(a)"
      using Finite_cardinal_iff' nat_into_Finite[of "succ(n)"]
      by fastforce
    show "\<exists>D. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>"
    proof (cases "\<exists>p. {A\<in>G . p \<in> A} \<approx> \<aleph>\<^bsub>1\<^esub>")
      case True \<comment> \<open>the positive case, uncountably many sets with a
                    common element\<close>
      then
      obtain p where "{A\<in>G . p \<in> A} \<approx> \<aleph>\<^bsub>1\<^esub>" by blast
      moreover from this
      have "{A-{p} . A\<in>{X\<in>G. p\<in>X}} \<approx> \<aleph>\<^bsub>1\<^esub>" (is "?F \<approx> _")
        using Diff_bij[of "{A\<in>G . p \<in> A}" "{p}"]
          comp_bij[OF bij_converse_bij, where C="\<aleph>\<^bsub>1\<^esub>"] by fast
      text\<open>Now using the hypothesis of the successor case,\<close>
      moreover from \<open>\<And>A. A\<in>G \<Longrightarrow> |A|=succ(n)\<close> \<open>\<forall>a\<in>G. Finite(a)\<close>
        and this
      have "p\<in>A \<Longrightarrow> A\<in>G \<Longrightarrow> |A - {p}| = n" for A
        using Finite_imp_succ_cardinal_Diff[of _ p] by force
      moreover from this and \<open>n\<in>\<omega>\<close>
      have "\<forall>a\<in>?F. Finite(a)"
        using Finite_cardinal_iff' nat_into_Finite by auto
      moreover
      text\<open>we may apply the inductive hypothesis to the new family \<^term>\<open>?F\<close>:\<close>
      note \<open>(\<And>A. A \<in> ?F \<Longrightarrow> |A| = n) \<Longrightarrow> ?F \<approx> \<aleph>\<^bsub>1\<^esub> \<Longrightarrow>
             \<exists>D. D \<subseteq> ?F \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
      ultimately
      obtain D where "D\<subseteq>{A-{p} . A\<in>{X\<in>G. p\<in>X}}" "delta_system(D)" "D \<approx> \<aleph>\<^bsub>1\<^esub>"
        by auto
      moreover from this
      obtain r where "\<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"
        by fastforce
      then
      have "\<forall>A\<in>D.\<forall>B\<in>D. A\<union>{p} \<noteq> B\<union>{p}\<longrightarrow>(A \<union> {p}) \<inter> (B \<union> {p}) = r\<union>{p}"
        by blast
      ultimately
      have "delta_system({B \<union> {p} . B\<in>D})" (is "delta_system(?D)")
        by fastforce
      moreover from \<open>D \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
      have "|D| = \<aleph>\<^bsub>1\<^esub>" "Infinite(D)"
        using cardinal_eqpoll_iff
        by (auto intro!: uncountable_iff_subset_eqpoll_Aleph1[THEN iffD2]
            uncountable_imp_Infinite) force
      moreover from this
      have "?D \<approx> \<aleph>\<^bsub>1\<^esub>"
        using cardinal_map_Un[of D "{p}"] naturals_lt_nat
          cardinal_eqpoll_iff[THEN iffD1] by simp
      moreover
      note \<open>D \<subseteq> {A-{p} . A\<in>{X\<in>G. p\<in>X}}\<close>
      have "?D \<subseteq> G"
      proof -
        {
          fix A
          assume "A\<in>G" "p\<in>A"
          moreover from this
          have "A = A - {p} \<union> {p}"
            by blast
          ultimately
          have "A -{p} \<union> {p} \<in> G"
            by auto
        }
        with \<open>D \<subseteq> {A-{p} . A\<in>{X\<in>G. p\<in>X}}\<close>
        show ?thesis
          by blast
      qed
      ultimately
      show "\<exists>D. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>" by auto
    next
      case False
      note \<open>\<not> (\<exists>p. {A \<in> G . p \<in> A} \<approx> \<aleph>\<^bsub>1\<^esub>)\<close> \<comment> \<open>the other case\<close>
      moreover from \<open>G \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
      have "{A \<in> G . p \<in> A} \<lesssim> \<aleph>\<^bsub>1\<^esub>" (is "?G(p) \<lesssim> _") for p
        by (blast intro:lepoll_eq_trans[OF subset_imp_lepoll])
      ultimately
      have "?G(p) \<prec> \<aleph>\<^bsub>1\<^esub>" for p
        unfolding lesspoll_def by simp
      then (* may omit the previous step if unfolding here: *)
      have "?G(p) \<lesssim> \<omega>" for p
        using lesspoll_aleph_plus_one[of 0] Aleph_zero_eq_nat by auto
      moreover
      have "{A \<in> G . S \<inter> A \<noteq> 0} = (\<Union>p\<in>S. ?G(p))" for S
        by auto
      ultimately
      have "countable(S) \<Longrightarrow> countable({A \<in> G . S \<inter> A \<noteq> 0})" for S
        using InfCard_nat Card_nat
         le_Card_iff[THEN iffD2, THEN [3] lepoll_imp_cardinal_UN_le,
           THEN [2] le_Card_iff[THEN iffD1], of \<omega> S]
        unfolding countable_def by simp
      text\<open>For every countable subfamily of \<^term>\<open>G\<close> there is another some
      element disjoint from all of them:\<close>
      have "\<exists>A\<in>G. \<forall>S\<in>X. S \<inter> A = 0" if "|X| < \<aleph>\<^bsub>1\<^esub>" "X \<subseteq> G" for X
      proof -
        from \<open>n\<in>\<omega>\<close> \<open>\<And>A. A\<in>G \<Longrightarrow> |A| = succ(n)\<close>
        have "A\<in>G \<Longrightarrow> Finite(A)" for A
          using cardinal_Card_eqpoll_iff
          unfolding Finite_def by fastforce
        with \<open>X\<subseteq>G\<close>
        have "A\<in>X \<Longrightarrow> countable(A)" for A
          using Finite_imp_countable by auto
        with \<open>|X| < \<aleph>\<^bsub>1\<^esub>\<close>
        have "countable(\<Union>X)"
          using Card_nat[THEN cardinal_lt_csucc_iff, of X]
            countable_union_countable countable_iff_cardinal_le_nat
          unfolding Aleph_def by simp
        with \<open>countable(_) \<Longrightarrow> countable({A \<in> G . _  \<inter> A \<noteq> 0})\<close>
        have "countable({A \<in> G . (\<Union>X) \<inter> A \<noteq> 0})" .
        with \<open>G \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
        obtain B where "B\<in>G" "B \<notin> {A \<in> G . (\<Union>X) \<inter> A \<noteq> 0}"
          using nat_lt_Aleph1 cardinal_Card_eqpoll_iff[of "\<aleph>\<^bsub>1\<^esub>" G]
            uncountable_not_subset_countable[of "{A \<in> G . (\<Union>X) \<inter> A \<noteq> 0}" G]
            uncountable_iff_nat_lt_cardinal
          by auto
        then
        show "\<exists>A\<in>G. \<forall>S\<in>X. S \<inter> A = 0" by auto
      qed
      moreover from \<open>G \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
      obtain b where "b\<in>G"
        using uncountable_iff_subset_eqpoll_Aleph1
          uncountable_not_empty by blast
      ultimately
      text\<open>Hence, the hypotheses to perform a bounded-cardinal selection
      are satisfied,\<close>
      obtain S where "S:\<aleph>\<^bsub>1\<^esub>\<rightarrow>G" "\<alpha>\<in>\<aleph>\<^bsub>1\<^esub> \<Longrightarrow> \<beta>\<in>\<aleph>\<^bsub>1\<^esub> \<Longrightarrow> \<alpha><\<beta> \<Longrightarrow> S`\<alpha> \<inter> S`\<beta> = 0"
        for \<alpha> \<beta>
        using bounded_cardinal_selection[of "\<aleph>\<^bsub>1\<^esub>" G "\<lambda>s a. s \<inter> a = 0" b]
        by force
      then
      have "\<alpha> \<in> \<aleph>\<^bsub>1\<^esub> \<Longrightarrow> \<beta> \<in> \<aleph>\<^bsub>1\<^esub> \<Longrightarrow> \<alpha>\<noteq>\<beta> \<Longrightarrow> S`\<alpha> \<inter> S`\<beta> = 0" for \<alpha> \<beta>
        using lt_neq_symmetry[of "\<aleph>\<^bsub>1\<^esub>" "\<lambda>\<alpha> \<beta>. S`\<alpha> \<inter> S`\<beta> = 0"] Card_is_Ord
        by auto blast
      text\<open>and a symmetry argument shows that obtained \<^term>\<open>S\<close> is
      an injective  \<^term>\<open>\<aleph>\<^bsub>1\<^esub>\<close>-sequence of disjoint elements of \<^term>\<open>G\<close>.\<close>
      moreover from this and \<open>\<And>A. A\<in>G \<Longrightarrow> |A| = succ(n)\<close> \<open>S : \<aleph>\<^bsub>1\<^esub> \<rightarrow> G\<close>
      have "S \<in> inj(\<aleph>\<^bsub>1\<^esub>, G)"
        using cardinal_succ_not_0 Int_eq_zero_imp_not_eq[of "\<aleph>\<^bsub>1\<^esub>" "\<lambda>x. S`x"]
        unfolding inj_def by fastforce
      moreover from calculation
      have "range(S) \<approx> \<aleph>\<^bsub>1\<^esub>"
        using inj_bij_range eqpoll_sym unfolding eqpoll_def by fast
      moreover from calculation
      have "range(S) \<subseteq> G"
        using inj_is_fun range_fun_subset_codomain by fast
      ultimately
      show "\<exists>D. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>"
        using inj_is_fun range_eq_image[of S "\<aleph>\<^bsub>1\<^esub>" G]
          image_function[OF fun_is_function, OF inj_is_fun, of S "\<aleph>\<^bsub>1\<^esub>" G]
          domain_of_fun[OF inj_is_fun, of S "\<aleph>\<^bsub>1\<^esub>" G]
        by (rule_tac x="S``\<aleph>\<^bsub>1\<^esub>" in exI) auto
      text\<open>This finishes the successor case and hence the proof.\<close>
    qed
  qed
  with \<open>G \<subseteq> F\<close>
  show ?thesis by blast
qed

lemma delta_system_uncountable:
  assumes "\<forall>A\<in>F. Finite(A)" "uncountable(F)"
  shows "\<exists>D. D \<subseteq> F \<and> delta_system(D) \<and> D \<approx> \<aleph>\<^bsub>1\<^esub>"
proof -
  from assms
  obtain S where "S \<subseteq> F" "S \<approx> \<aleph>\<^bsub>1\<^esub>"
    using uncountable_iff_subset_eqpoll_Aleph1[of F] by auto
  moreover from \<open>\<forall>A\<in>F. Finite(A)\<close> and this
  have "\<forall>A\<in>S. Finite(A)" by auto
  ultimately
  show ?thesis using delta_system_Aleph1[of S]
    by auto
qed

end