(*  Title:      HOL/Analysis/Finite_Cartesian_Product.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section \<open>Definition of Finite Cartesian Product Type\<close>

theory Finite_Cartesian_Product
imports
  Euclidean_Space
  L2_Norm
  "HOL-Library.Numeral_Type"
  "HOL-Library.Countable_Set"
  "HOL-Library.FuncSet"
begin

subsection\<^marker>\<open>tag unimportant\<close> \<open>Finite Cartesian products, with indexing and lambdas\<close>

typedef ('a, 'b) vec = "UNIV :: ('b::finite \<Rightarrow> 'a) set"
  morphisms vec_nth vec_lambda ..

declare vec_lambda_inject [simplified, simp]

bundle vec_syntax begin
notation
  vec_nth (infixl "$" 90) and
  vec_lambda (binder "\<chi>" 10)
end

bundle no_vec_syntax begin
no_notation
  vec_nth (infixl "$" 90) and
  vec_lambda (binder "\<chi>" 10)
end

unbundle vec_syntax

text \<open>
  Concrete syntax for \<open>('a, 'b) vec\<close>:
    \<^item> \<open>'a^'b\<close> becomes \<open>('a, 'b::finite) vec\<close>
    \<^item> \<open>'a^'b::_\<close> becomes \<open>('a, 'b) vec\<close> without extra sort-constraint
\<close>
syntax "_vec_type" :: "type \<Rightarrow> type \<Rightarrow> type" (infixl "^" 15)
parse_translation \<open>
  let
    fun vec t u = Syntax.const \<^type_syntax>\<open>vec\<close> $ t $ u;
    fun finite_vec_tr [t, u] =
      (case Term_Position.strip_positions u of
        v as Free (x, _) =>
          if Lexicon.is_tid x then
            vec t (Syntax.const \<^syntax_const>\<open>_ofsort\<close> $ v $
              Syntax.const \<^class_syntax>\<open>finite\<close>)
          else vec t u
      | _ => vec t u)
  in
    [(\<^syntax_const>\<open>_vec_type\<close>, K finite_vec_tr)]
  end
\<close>

lemma vec_eq_iff: "(x = y) \<longleftrightarrow> (\<forall>i. x$i = y$i)"
  by (simp add: vec_nth_inject [symmetric] fun_eq_iff)

lemma vec_lambda_beta [simp]: "vec_lambda g $ i = g i"
  by (simp add: vec_lambda_inverse)

lemma vec_lambda_unique: "(\<forall>i. f$i = g i) \<longleftrightarrow> vec_lambda g = f"
  by (auto simp add: vec_eq_iff)

lemma vec_lambda_eta [simp]: "(\<chi> i. (g$i)) = g"
  by (simp add: vec_eq_iff)

subsection \<open>Cardinality of vectors\<close>

instance vec :: (finite, finite) finite
proof
  show "finite (UNIV :: ('a, 'b) vec set)"
  proof (subst bij_betw_finite)
    show "bij_betw vec_nth UNIV (Pi (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set))"
      by (intro bij_betwI[of _ _ _ vec_lambda]) (auto simp: vec_eq_iff)
    have "finite (PiE (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set))"
      by (intro finite_PiE) auto
    also have "(PiE (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set)) = Pi UNIV (\<lambda>_. UNIV)"
      by auto
    finally show "finite \<dots>" .
  qed
qed

lemma countable_PiE:
  "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> countable (F i)) \<Longrightarrow> countable (Pi\<^sub>E I F)"
  by (induct I arbitrary: F rule: finite_induct) (auto simp: PiE_insert_eq)

instance vec :: (countable, finite) countable
proof
  have "countable (UNIV :: ('a, 'b) vec set)"
  proof (rule countableI_bij2)
    show "bij_betw vec_nth UNIV (Pi (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set))"
      by (intro bij_betwI[of _ _ _ vec_lambda]) (auto simp: vec_eq_iff)
    have "countable (PiE (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set))"
      by (intro countable_PiE) auto
    also have "(PiE (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set)) = Pi UNIV (\<lambda>_. UNIV)"
      by auto
    finally show "countable \<dots>" .
  qed
  thus "\<exists>t::('a, 'b) vec \<Rightarrow> nat. inj t"
    by (auto elim!: countableE)
qed

lemma infinite_UNIV_vec:
  assumes "infinite (UNIV :: 'a set)"
  shows   "infinite (UNIV :: ('a^'b) set)"
proof (subst bij_betw_finite)
  show "bij_betw vec_nth UNIV (Pi (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set))"
    by (intro bij_betwI[of _ _ _ vec_lambda]) (auto simp: vec_eq_iff)
  have "infinite (PiE (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set))" (is "infinite ?A")
  proof
    assume "finite ?A"
    hence "finite ((\<lambda>f. f undefined) ` ?A)"
      by (rule finite_imageI)
    also have "(\<lambda>f. f undefined) ` ?A = UNIV"
      by auto
    finally show False
      using \<open>infinite (UNIV :: 'a set)\<close> by contradiction
  qed
  also have "?A = Pi UNIV (\<lambda>_. UNIV)"
    by auto
  finally show "infinite (Pi (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set))" .
qed

proposition CARD_vec [simp]:
  "CARD('a^'b) = CARD('a) ^ CARD('b)"
proof (cases "finite (UNIV :: 'a set)")
  case True
  show ?thesis
  proof (subst bij_betw_same_card)
    show "bij_betw vec_nth UNIV (Pi (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set))"
      by (intro bij_betwI[of _ _ _ vec_lambda]) (auto simp: vec_eq_iff)
    have "CARD('a) ^ CARD('b) = card (PiE (UNIV :: 'b set) (\<lambda>_. UNIV :: 'a set))"
      (is "_ = card ?A")
      by (subst card_PiE) (auto)
    also have "?A = Pi UNIV (\<lambda>_. UNIV)"
      by auto
    finally show "card \<dots> = CARD('a) ^ CARD('b)" ..
  qed
qed (simp_all add: infinite_UNIV_vec)

lemma countable_vector:
  fixes B:: "'n::finite \<Rightarrow> 'a set"
  assumes "\<And>i. countable (B i)"
  shows "countable {V. \<forall>i::'n::finite. V $ i \<in> B i}"
proof -
  have "f \<in> ($) ` {V. \<forall>i. V $ i \<in> B i}" if "f \<in> Pi\<^sub>E UNIV B" for f
  proof -
    have "\<exists>W. (\<forall>i. W $ i \<in> B i) \<and> ($) W = f"
      by (metis that PiE_iff UNIV_I vec_lambda_inverse)
    then show "f \<in> ($) ` {v. \<forall>i. v $ i \<in> B i}"
      by blast
  qed
  then have "Pi\<^sub>E UNIV B = vec_nth ` {V. \<forall>i::'n. V $ i \<in> B i}"
    by blast
  then have "countable (vec_nth ` {V. \<forall>i. V $ i \<in> B i})"
    by (metis finite_class.finite_UNIV countable_PiE assms)
  then have "countable (vec_lambda ` vec_nth ` {V. \<forall>i. V $ i \<in> B i})"
    by auto
  then show ?thesis
    by (simp add: image_comp o_def vec_nth_inverse)
qed

subsection\<^marker>\<open>tag unimportant\<close> \<open>Group operations and class instances\<close>

instantiation vec :: (zero, finite) zero
begin
  definition "0 \<equiv> (\<chi> i. 0)"
  instance ..
end

instantiation vec :: (plus, finite) plus
begin
  definition "(+) \<equiv> (\<lambda> x y. (\<chi> i. x$i + y$i))"
  instance ..
end

instantiation vec :: (minus, finite) minus
begin
  definition "(-) \<equiv> (\<lambda> x y. (\<chi> i. x$i - y$i))"
  instance ..
end

instantiation vec :: (uminus, finite) uminus
begin
  definition "uminus \<equiv> (\<lambda> x. (\<chi> i. - (x$i)))"
  instance ..
end

lemma zero_index [simp]: "0 $ i = 0"
  unfolding zero_vec_def by simp

lemma vector_add_component [simp]: "(x + y)$i = x$i + y$i"
  unfolding plus_vec_def by simp

lemma vector_minus_component [simp]: "(x - y)$i = x$i - y$i"
  unfolding minus_vec_def by simp

lemma vector_uminus_component [simp]: "(- x)$i = - (x$i)"
  unfolding uminus_vec_def by simp

instance vec :: (semigroup_add, finite) semigroup_add
  by standard (simp add: vec_eq_iff add.assoc)

instance vec :: (ab_semigroup_add, finite) ab_semigroup_add
  by standard (simp add: vec_eq_iff add.commute)

instance vec :: (monoid_add, finite) monoid_add
  by standard (simp_all add: vec_eq_iff)

instance vec :: (comm_monoid_add, finite) comm_monoid_add
  by standard (simp add: vec_eq_iff)

instance vec :: (cancel_semigroup_add, finite) cancel_semigroup_add
  by standard (simp_all add: vec_eq_iff)

instance vec :: (cancel_ab_semigroup_add, finite) cancel_ab_semigroup_add
  by standard (simp_all add: vec_eq_iff diff_diff_eq)

instance vec :: (cancel_comm_monoid_add, finite) cancel_comm_monoid_add ..

instance vec :: (group_add, finite) group_add
  by standard (simp_all add: vec_eq_iff)

instance vec :: (ab_group_add, finite) ab_group_add
  by standard (simp_all add: vec_eq_iff)

subsection\<^marker>\<open>tag unimportant\<close>\<open>Basic componentwise operations on vectors\<close>

instantiation vec :: (times, finite) times
begin

definition "(*) \<equiv> (\<lambda> x y.  (\<chi> i. (x$i) * (y$i)))"
instance ..

end

instantiation vec :: (one, finite) one
begin

definition "1 \<equiv> (\<chi> i. 1)"
instance ..

end

instantiation vec :: (ord, finite) ord
begin

definition "x \<le> y \<longleftrightarrow> (\<forall>i. x$i \<le> y$i)"
definition "x < (y::'a^'b) \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
instance ..

end

text\<open>The ordering on one-dimensional vectors is linear.\<close>

instance vec:: (order, finite) order
  by standard (auto simp: less_eq_vec_def less_vec_def vec_eq_iff
      intro: order.trans order.antisym order.strict_implies_order)

instance vec :: (linorder, CARD_1) linorder
proof
  obtain a :: 'b where all: "\<And>P. (\<forall>i. P i) \<longleftrightarrow> P a"
  proof -
    have "CARD ('b) = 1" by (rule CARD_1)
    then obtain b :: 'b where "UNIV = {b}" by (auto iff: card_Suc_eq)
    then have "\<And>P. (\<forall>i\<in>UNIV. P i) \<longleftrightarrow> P b" by auto
    then show thesis by (auto intro: that)
  qed
  fix x y :: "'a^'b::CARD_1"
  note [simp] = less_eq_vec_def less_vec_def all vec_eq_iff field_simps
  show "x \<le> y \<or> y \<le> x" by auto
qed

text\<open>Constant Vectors\<close>

definition "vec x = (\<chi> i. x)"

text\<open>Also the scalar-vector multiplication.\<close>

definition vector_scalar_mult:: "'a::times \<Rightarrow> 'a ^ 'n \<Rightarrow> 'a ^ 'n" (infixl "*s" 70)
  where "c *s x = (\<chi> i. c * (x$i))"

text \<open>scalar product\<close>

definition scalar_product :: "'a :: semiring_1 ^ 'n \<Rightarrow> 'a ^ 'n \<Rightarrow> 'a" where
  "scalar_product v w = (\<Sum> i \<in> UNIV. v $ i * w $ i)"

subsection \<open>Real vector space\<close>

instantiation\<^marker>\<open>tag unimportant\<close> vec :: (real_vector, finite) real_vector
begin

definition\<^marker>\<open>tag important\<close> "scaleR \<equiv> (\<lambda> r x. (\<chi> i. scaleR r (x$i)))"

lemma vector_scaleR_component [simp]: "(scaleR r x)$i = scaleR r (x$i)"
  unfolding scaleR_vec_def by simp

instance\<^marker>\<open>tag unimportant\<close>
  by standard (simp_all add: vec_eq_iff scaleR_left_distrib scaleR_right_distrib)

end

subsection \<open>Topological space\<close>

instantiation\<^marker>\<open>tag unimportant\<close> vec :: (topological_space, finite) topological_space
begin

definition\<^marker>\<open>tag important\<close> [code del]:
  "open (S :: ('a ^ 'b) set) \<longleftrightarrow>
    (\<forall>x\<in>S. \<exists>A. (\<forall>i. open (A i) \<and> x$i \<in> A i) \<and>
      (\<forall>y. (\<forall>i. y$i \<in> A i) \<longrightarrow> y \<in> S))"

instance\<^marker>\<open>tag unimportant\<close> proof
  show "open (UNIV :: ('a ^ 'b) set)"
    unfolding open_vec_def by auto
next
  fix S T :: "('a ^ 'b) set"
  assume "open S" "open T" thus "open (S \<inter> T)"
    unfolding open_vec_def
    apply clarify
    apply (drule (1) bspec)+
    apply (clarify, rename_tac Sa Ta)
    apply (rule_tac x="\<lambda>i. Sa i \<inter> Ta i" in exI)
    apply (simp add: open_Int)
    done
next
  fix K :: "('a ^ 'b) set set"
  assume "\<forall>S\<in>K. open S" thus "open (\<Union>K)"
    unfolding open_vec_def
    by (metis Union_iff)
qed

end

lemma open_vector_box: "\<forall>i. open (S i) \<Longrightarrow> open {x. \<forall>i. x $ i \<in> S i}"
  unfolding open_vec_def by auto

lemma open_vimage_vec_nth: "open S \<Longrightarrow> open ((\<lambda>x. x $ i) -` S)"
  unfolding open_vec_def
  apply clarify
  apply (rule_tac x="\<lambda>k. if k = i then S else UNIV" in exI, simp)
  done

lemma closed_vimage_vec_nth: "closed S \<Longrightarrow> closed ((\<lambda>x. x $ i) -` S)"
  unfolding closed_open vimage_Compl [symmetric]
  by (rule open_vimage_vec_nth)

lemma closed_vector_box: "\<forall>i. closed (S i) \<Longrightarrow> closed {x. \<forall>i. x $ i \<in> S i}"
proof -
  have "{x. \<forall>i. x $ i \<in> S i} = (\<Inter>i. (\<lambda>x. x $ i) -` S i)" by auto
  thus "\<forall>i. closed (S i) \<Longrightarrow> closed {x. \<forall>i. x $ i \<in> S i}"
    by (simp add: closed_INT closed_vimage_vec_nth)
qed

lemma tendsto_vec_nth [tendsto_intros]:
  assumes "((\<lambda>x. f x) \<longlongrightarrow> a) net"
  shows "((\<lambda>x. f x $ i) \<longlongrightarrow> a $ i) net"
proof (rule topological_tendstoI)
  fix S assume "open S" "a $ i \<in> S"
  then have "open ((\<lambda>y. y $ i) -` S)" "a \<in> ((\<lambda>y. y $ i) -` S)"
    by (simp_all add: open_vimage_vec_nth)
  with assms have "eventually (\<lambda>x. f x \<in> (\<lambda>y. y $ i) -` S) net"
    by (rule topological_tendstoD)
  then show "eventually (\<lambda>x. f x $ i \<in> S) net"
    by simp
qed

lemma isCont_vec_nth [simp]: "isCont f a \<Longrightarrow> isCont (\<lambda>x. f x $ i) a"
  unfolding isCont_def by (rule tendsto_vec_nth)

lemma vec_tendstoI:
  assumes "\<And>i. ((\<lambda>x. f x $ i) \<longlongrightarrow> a $ i) net"
  shows "((\<lambda>x. f x) \<longlongrightarrow> a) net"
proof (rule topological_tendstoI)
  fix S assume "open S" and "a \<in> S"
  then obtain A where A: "\<And>i. open (A i)" "\<And>i. a $ i \<in> A i"
    and S: "\<And>y. \<forall>i. y $ i \<in> A i \<Longrightarrow> y \<in> S"
    unfolding open_vec_def by metis
  have "\<And>i. eventually (\<lambda>x. f x $ i \<in> A i) net"
    using assms A by (rule topological_tendstoD)
  hence "eventually (\<lambda>x. \<forall>i. f x $ i \<in> A i) net"
    by (rule eventually_all_finite)
  thus "eventually (\<lambda>x. f x \<in> S) net"
    by (rule eventually_mono, simp add: S)
qed

lemma tendsto_vec_lambda [tendsto_intros]:
  assumes "\<And>i. ((\<lambda>x. f x i) \<longlongrightarrow> a i) net"
  shows "((\<lambda>x. \<chi> i. f x i) \<longlongrightarrow> (\<chi> i. a i)) net"
  using assms by (simp add: vec_tendstoI)

lemma open_image_vec_nth: assumes "open S" shows "open ((\<lambda>x. x $ i) ` S)"
proof (rule openI)
  fix a assume "a \<in> (\<lambda>x. x $ i) ` S"
  then obtain z where "a = z $ i" and "z \<in> S" ..
  then obtain A where A: "\<forall>i. open (A i) \<and> z $ i \<in> A i"
    and S: "\<forall>y. (\<forall>i. y $ i \<in> A i) \<longrightarrow> y \<in> S"
    using \<open>open S\<close> unfolding open_vec_def by auto
  hence "A i \<subseteq> (\<lambda>x. x $ i) ` S"
    by (clarsimp, rule_tac x="\<chi> j. if j = i then x else z $ j" in image_eqI,
      simp_all)
  hence "open (A i) \<and> a \<in> A i \<and> A i \<subseteq> (\<lambda>x. x $ i) ` S"
    using A \<open>a = z $ i\<close> by simp
  then show "\<exists>T. open T \<and> a \<in> T \<and> T \<subseteq> (\<lambda>x. x $ i) ` S" by - (rule exI)
qed

instance\<^marker>\<open>tag unimportant\<close> vec :: (perfect_space, finite) perfect_space
proof
  fix x :: "'a ^ 'b" show "\<not> open {x}"
  proof
    assume "open {x}"
    hence "\<forall>i. open ((\<lambda>x. x $ i) ` {x})" by (fast intro: open_image_vec_nth)
    hence "\<forall>i. open {x $ i}" by simp
    thus "False" by (simp add: not_open_singleton)
  qed
qed

subsection \<open>Metric space\<close>
(* TODO: Product of uniform spaces and compatibility with metric_spaces! *)

instantiation\<^marker>\<open>tag unimportant\<close> vec :: (metric_space, finite) dist
begin

definition\<^marker>\<open>tag important\<close>
  "dist x y = L2_set (\<lambda>i. dist (x$i) (y$i)) UNIV"

instance ..
end

instantiation\<^marker>\<open>tag unimportant\<close> vec :: (metric_space, finite) uniformity_dist
begin

definition\<^marker>\<open>tag important\<close> [code del]:
  "(uniformity :: (('a^'b::_) \<times> ('a^'b::_)) filter) =
    (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"

instance\<^marker>\<open>tag unimportant\<close>
  by standard (rule uniformity_vec_def)
end

declare uniformity_Abort[where 'a="'a :: metric_space ^ 'b :: finite", code]

instantiation\<^marker>\<open>tag unimportant\<close> vec :: (metric_space, finite) metric_space
begin

proposition dist_vec_nth_le: "dist (x $ i) (y $ i) \<le> dist x y"
  unfolding dist_vec_def by (rule member_le_L2_set) simp_all

instance proof
  fix x y :: "'a ^ 'b"
  show "dist x y = 0 \<longleftrightarrow> x = y"
    unfolding dist_vec_def
    by (simp add: L2_set_eq_0_iff vec_eq_iff)
next
  fix x y z :: "'a ^ 'b"
  show "dist x y \<le> dist x z + dist y z"
    unfolding dist_vec_def
    apply (rule order_trans [OF _ L2_set_triangle_ineq])
    apply (simp add: L2_set_mono dist_triangle2)
    done
next
  fix S :: "('a ^ 'b) set"
  have *: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"
  proof
    assume "open S" show "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S"
    proof
      fix x assume "x \<in> S"
      obtain A where A: "\<forall>i. open (A i)" "\<forall>i. x $ i \<in> A i"
        and S: "\<forall>y. (\<forall>i. y $ i \<in> A i) \<longrightarrow> y \<in> S"
        using \<open>open S\<close> and \<open>x \<in> S\<close> unfolding open_vec_def by metis
      have "\<forall>i\<in>UNIV. \<exists>r>0. \<forall>y. dist y (x $ i) < r \<longrightarrow> y \<in> A i"
        using A unfolding open_dist by simp
      hence "\<exists>r. \<forall>i\<in>UNIV. 0 < r i \<and> (\<forall>y. dist y (x $ i) < r i \<longrightarrow> y \<in> A i)"
        by (rule finite_set_choice [OF finite])
      then obtain r where r1: "\<forall>i. 0 < r i"
        and r2: "\<forall>i y. dist y (x $ i) < r i \<longrightarrow> y \<in> A i" by fast
      have "0 < Min (range r) \<and> (\<forall>y. dist y x < Min (range r) \<longrightarrow> y \<in> S)"
        by (simp add: r1 r2 S le_less_trans [OF dist_vec_nth_le])
      thus "\<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S" ..
    qed
  next
    assume *: "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S" show "open S"
    proof (unfold open_vec_def, rule)
      fix x assume "x \<in> S"
      then obtain e where "0 < e" and S: "\<forall>y. dist y x < e \<longrightarrow> y \<in> S"
        using * by fast
      define r where [abs_def]: "r i = e / sqrt (of_nat CARD('b))" for i :: 'b
      from \<open>0 < e\<close> have r: "\<forall>i. 0 < r i"
        unfolding r_def by simp_all
      from \<open>0 < e\<close> have e: "e = L2_set r UNIV"
        unfolding r_def by (simp add: L2_set_constant)
      define A where "A i = {y. dist (x $ i) y < r i}" for i
      have "\<forall>i. open (A i) \<and> x $ i \<in> A i"
        unfolding A_def by (simp add: open_ball r)
      moreover have "\<forall>y. (\<forall>i. y $ i \<in> A i) \<longrightarrow> y \<in> S"
        by (simp add: A_def S dist_vec_def e L2_set_strict_mono dist_commute)
      ultimately show "\<exists>A. (\<forall>i. open (A i) \<and> x $ i \<in> A i) \<and>
        (\<forall>y. (\<forall>i. y $ i \<in> A i) \<longrightarrow> y \<in> S)" by metis
    qed
  qed
  show "open S = (\<forall>x\<in>S. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> S)"
    unfolding * eventually_uniformity_metric
    by (simp del: split_paired_All add: dist_vec_def dist_commute)
qed

end

lemma Cauchy_vec_nth:
  "Cauchy (\<lambda>n. X n) \<Longrightarrow> Cauchy (\<lambda>n. X n $ i)"
  unfolding Cauchy_def by (fast intro: le_less_trans [OF dist_vec_nth_le])

lemma vec_CauchyI:
  fixes X :: "nat \<Rightarrow> 'a::metric_space ^ 'n"
  assumes X: "\<And>i. Cauchy (\<lambda>n. X n $ i)"
  shows "Cauchy (\<lambda>n. X n)"
proof (rule metric_CauchyI)
  fix r :: real assume "0 < r"
  hence "0 < r / of_nat CARD('n)" (is "0 < ?s") by simp
  define N where "N i = (LEAST N. \<forall>m\<ge>N. \<forall>n\<ge>N. dist (X m $ i) (X n $ i) < ?s)" for i
  define M where "M = Max (range N)"
  have "\<And>i. \<exists>N. \<forall>m\<ge>N. \<forall>n\<ge>N. dist (X m $ i) (X n $ i) < ?s"
    using X \<open>0 < ?s\<close> by (rule metric_CauchyD)
  hence "\<And>i. \<forall>m\<ge>N i. \<forall>n\<ge>N i. dist (X m $ i) (X n $ i) < ?s"
    unfolding N_def by (rule LeastI_ex)
  hence M: "\<And>i. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m $ i) (X n $ i) < ?s"
    unfolding M_def by simp
  {
    fix m n :: nat
    assume "M \<le> m" "M \<le> n"
    have "dist (X m) (X n) = L2_set (\<lambda>i. dist (X m $ i) (X n $ i)) UNIV"
      unfolding dist_vec_def ..
    also have "\<dots> \<le> sum (\<lambda>i. dist (X m $ i) (X n $ i)) UNIV"
      by (rule L2_set_le_sum [OF zero_le_dist])
    also have "\<dots> < sum (\<lambda>i::'n. ?s) UNIV"
      by (rule sum_strict_mono, simp_all add: M \<open>M \<le> m\<close> \<open>M \<le> n\<close>)
    also have "\<dots> = r"
      by simp
    finally have "dist (X m) (X n) < r" .
  }
  hence "\<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < r"
    by simp
  then show "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < r" ..
qed

instance\<^marker>\<open>tag unimportant\<close> vec :: (complete_space, finite) complete_space
proof
  fix X :: "nat \<Rightarrow> 'a ^ 'b" assume "Cauchy X"
  have "\<And>i. (\<lambda>n. X n $ i) \<longlonglongrightarrow> lim (\<lambda>n. X n $ i)"
    using Cauchy_vec_nth [OF \<open>Cauchy X\<close>]
    by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
  hence "X \<longlonglongrightarrow> vec_lambda (\<lambda>i. lim (\<lambda>n. X n $ i))"
    by (simp add: vec_tendstoI)
  then show "convergent X"
    by (rule convergentI)
qed

subsection \<open>Normed vector space\<close>

instantiation\<^marker>\<open>tag unimportant\<close> vec :: (real_normed_vector, finite) real_normed_vector
begin

definition\<^marker>\<open>tag important\<close> "norm x = L2_set (\<lambda>i. norm (x$i)) UNIV"

definition\<^marker>\<open>tag important\<close> "sgn (x::'a^'b) = scaleR (inverse (norm x)) x"

instance\<^marker>\<open>tag unimportant\<close> proof
  fix a :: real and x y :: "'a ^ 'b"
  show "norm x = 0 \<longleftrightarrow> x = 0"
    unfolding norm_vec_def
    by (simp add: L2_set_eq_0_iff vec_eq_iff)
  show "norm (x + y) \<le> norm x + norm y"
    unfolding norm_vec_def
    apply (rule order_trans [OF _ L2_set_triangle_ineq])
    apply (simp add: L2_set_mono norm_triangle_ineq)
    done
  show "norm (scaleR a x) = \<bar>a\<bar> * norm x"
    unfolding norm_vec_def
    by (simp add: L2_set_right_distrib)
  show "sgn x = scaleR (inverse (norm x)) x"
    by (rule sgn_vec_def)
  show "dist x y = norm (x - y)"
    unfolding dist_vec_def norm_vec_def
    by (simp add: dist_norm)
qed

end

lemma norm_nth_le: "norm (x $ i) \<le> norm x"
unfolding norm_vec_def
by (rule member_le_L2_set) simp_all

lemma norm_le_componentwise_cart:
  fixes x :: "'a::real_normed_vector^'n"
  assumes "\<And>i. norm(x$i) \<le> norm(y$i)"
  shows "norm x \<le> norm y"
  unfolding norm_vec_def
  by (rule L2_set_mono) (auto simp: assms)

lemma component_le_norm_cart: "\<bar>x$i\<bar> \<le> norm x"
  by (metis norm_nth_le real_norm_def)

lemma norm_bound_component_le_cart: "norm x \<le> e ==> \<bar>x$i\<bar> \<le> e"
  by (metis component_le_norm_cart order_trans)

lemma norm_bound_component_lt_cart: "norm x < e ==> \<bar>x$i\<bar> < e"
  by (metis component_le_norm_cart le_less_trans)

lemma norm_le_l1_cart: "norm x \<le> sum(\<lambda>i. \<bar>x$i\<bar>) UNIV"
  by (simp add: norm_vec_def L2_set_le_sum)

lemma bounded_linear_vec_nth[intro]: "bounded_linear (\<lambda>x. x $ i)"
proof
  show "\<exists>K. \<forall>x. norm (x $ i) \<le> norm x * K"
    by (metis mult.commute mult.left_neutral norm_nth_le)
qed auto

instance vec :: (banach, finite) banach ..

subsection \<open>Inner product space\<close>

instantiation\<^marker>\<open>tag unimportant\<close> vec :: (real_inner, finite) real_inner
begin

definition\<^marker>\<open>tag important\<close> "inner x y = sum (\<lambda>i. inner (x$i) (y$i)) UNIV"

instance\<^marker>\<open>tag unimportant\<close> proof
  fix r :: real and x y z :: "'a ^ 'b"
  show "inner x y = inner y x"
    unfolding inner_vec_def
    by (simp add: inner_commute)
  show "inner (x + y) z = inner x z + inner y z"
    unfolding inner_vec_def
    by (simp add: inner_add_left sum.distrib)
  show "inner (scaleR r x) y = r * inner x y"
    unfolding inner_vec_def
    by (simp add: sum_distrib_left)
  show "0 \<le> inner x x"
    unfolding inner_vec_def
    by (simp add: sum_nonneg)
  show "inner x x = 0 \<longleftrightarrow> x = 0"
    unfolding inner_vec_def
    by (simp add: vec_eq_iff sum_nonneg_eq_0_iff)
  show "norm x = sqrt (inner x x)"
    unfolding inner_vec_def norm_vec_def L2_set_def
    by (simp add: power2_norm_eq_inner)
qed

end

subsection \<open>Euclidean space\<close>

text \<open>Vectors pointing along a single axis.\<close>

definition\<^marker>\<open>tag important\<close> "axis k x = (\<chi> i. if i = k then x else 0)"

lemma axis_nth [simp]: "axis i x $ i = x"
  unfolding axis_def by simp

lemma axis_eq_axis: "axis i x = axis j y \<longleftrightarrow> x = y \<and> i = j \<or> x = 0 \<and> y = 0"
  unfolding axis_def vec_eq_iff by auto

lemma inner_axis_axis:
  "inner (axis i x) (axis j y) = (if i = j then inner x y else 0)"
  by (simp add: inner_vec_def axis_def sum.neutral sum.remove [of _ j])

lemma inner_axis: "inner x (axis i y) = inner (x $ i) y"
  by (simp add: inner_vec_def axis_def sum.remove [where x=i])

lemma inner_axis': "inner(axis i y) x = inner y (x $ i)"
  by (simp add: inner_axis inner_commute)

instantiation\<^marker>\<open>tag unimportant\<close> vec :: (euclidean_space, finite) euclidean_space
begin

definition\<^marker>\<open>tag important\<close> "Basis = (\<Union>i. \<Union>u\<in>Basis. {axis i u})"

instance\<^marker>\<open>tag unimportant\<close> proof
  show "(Basis :: ('a ^ 'b) set) \<noteq> {}"
    unfolding Basis_vec_def by simp
next
  show "finite (Basis :: ('a ^ 'b) set)"
    unfolding Basis_vec_def by simp
next
  fix u v :: "'a ^ 'b"
  assume "u \<in> Basis" and "v \<in> Basis"
  thus "inner u v = (if u = v then 1 else 0)"
    unfolding Basis_vec_def
    by (auto simp add: inner_axis_axis axis_eq_axis inner_Basis)
next
  fix x :: "'a ^ 'b"
  show "(\<forall>u\<in>Basis. inner x u = 0) \<longleftrightarrow> x = 0"
    unfolding Basis_vec_def
    by (simp add: inner_axis euclidean_all_zero_iff vec_eq_iff)
qed

proposition DIM_cart [simp]: "DIM('a^'b) = CARD('b) * DIM('a)"
proof -
  have "card (\<Union>i::'b. \<Union>u::'a\<in>Basis. {axis i u}) = (\<Sum>i::'b\<in>UNIV. card (\<Union>u::'a\<in>Basis. {axis i u}))"
    by (rule card_UN_disjoint) (auto simp: axis_eq_axis)
  also have "... = CARD('b) * DIM('a)"
    by (subst card_UN_disjoint) (auto simp: axis_eq_axis)
  finally show ?thesis
    by (simp add: Basis_vec_def)
qed

end

lemma norm_axis_1 [simp]: "norm (axis m (1::real)) = 1"
  by (simp add: inner_axis' norm_eq_1)

lemma sum_norm_allsubsets_bound_cart:
  fixes f:: "'a \<Rightarrow> real ^'n"
  assumes fP: "finite P" and fPs: "\<And>Q. Q \<subseteq> P \<Longrightarrow> norm (sum f Q) \<le> e"
  shows "sum (\<lambda>x. norm (f x)) P \<le> 2 * real CARD('n) *  e"
  using sum_norm_allsubsets_bound[OF assms]
  by simp

lemma cart_eq_inner_axis: "a $ i = inner a (axis i 1)"
  by (simp add: inner_axis)

lemma axis_eq_0_iff [simp]:
  shows "axis m x = 0 \<longleftrightarrow> x = 0"
  by (simp add: axis_def vec_eq_iff)

lemma axis_in_Basis_iff [simp]: "axis i a \<in> Basis \<longleftrightarrow> a \<in> Basis"
  by (auto simp: Basis_vec_def axis_eq_axis)

text\<open>Mapping each basis element to the corresponding finite index\<close>
definition axis_index :: "('a::comm_ring_1)^'n \<Rightarrow> 'n" where "axis_index v \<equiv> SOME i. v = axis i 1"

lemma axis_inverse:
  fixes v :: "real^'n"
  assumes "v \<in> Basis"
  shows "\<exists>i. v = axis i 1"
proof -
  have "v \<in> (\<Union>n. \<Union>r\<in>Basis. {axis n r})"
    using assms Basis_vec_def by blast
  then show ?thesis
    by (force simp add: vec_eq_iff)
qed

lemma axis_index:
  fixes v :: "real^'n"
  assumes "v \<in> Basis"
  shows "v = axis (axis_index v) 1"
  by (metis (mono_tags) assms axis_inverse axis_index_def someI_ex)

lemma axis_index_axis [simp]:
  fixes UU :: "real^'n"
  shows "(axis_index (axis u 1 :: real^'n)) = (u::'n)"
  by (simp add: axis_eq_axis axis_index_def)

subsection\<^marker>\<open>tag unimportant\<close> \<open>A naive proof procedure to lift really trivial arithmetic stuff from the basis of the vector space\<close>

lemma sum_cong_aux:
  "(\<And>x. x \<in> A \<Longrightarrow> f x = g x) \<Longrightarrow> sum f A = sum g A"
  by (auto intro: sum.cong)

hide_fact (open) sum_cong_aux

method_setup vector = \<open>
let
  val ss1 =
    simpset_of (put_simpset HOL_basic_ss \<^context>
      addsimps [@{thm sum.distrib} RS sym,
      @{thm sum_subtractf} RS sym, @{thm sum_distrib_left},
      @{thm sum_distrib_right}, @{thm sum_negf} RS sym])
  val ss2 =
    simpset_of (\<^context> addsimps
             [@{thm plus_vec_def}, @{thm times_vec_def},
              @{thm minus_vec_def}, @{thm uminus_vec_def},
              @{thm one_vec_def}, @{thm zero_vec_def}, @{thm vec_def},
              @{thm scaleR_vec_def}, @{thm vector_scalar_mult_def}])
  fun vector_arith_tac ctxt ths =
    simp_tac (put_simpset ss1 ctxt)
    THEN' (fn i => resolve_tac ctxt @{thms Finite_Cartesian_Product.sum_cong_aux} i
         ORELSE resolve_tac ctxt @{thms sum.neutral} i
         ORELSE simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm vec_eq_iff}]) i)
    (* THEN' TRY o clarify_tac HOL_cs  THEN' (TRY o rtac @{thm iffI}) *)
    THEN' asm_full_simp_tac (put_simpset ss2 ctxt addsimps ths)
in
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (vector_arith_tac ctxt ths))
end
\<close> "lift trivial vector statements to real arith statements"

lemma vec_0[simp]: "vec 0 = 0" by vector
lemma vec_1[simp]: "vec 1 = 1" by vector

lemma vec_inj[simp]: "vec x = vec y \<longleftrightarrow> x = y" by vector

lemma vec_in_image_vec: "vec x \<in> (vec ` S) \<longleftrightarrow> x \<in> S" by auto

lemma vec_add: "vec(x + y) = vec x + vec y"  by vector
lemma vec_sub: "vec(x - y) = vec x - vec y" by vector
lemma vec_cmul: "vec(c * x) = c *s vec x " by vector
lemma vec_neg: "vec(- x) = - vec x " by vector

lemma vec_scaleR: "vec(c * x) = c *\<^sub>R vec x"
  by vector

lemma vec_sum:
  assumes "finite S"
  shows "vec(sum f S) = sum (vec \<circ> f) S"
  using assms
proof induct
  case empty
  then show ?case by simp
next
  case insert
  then show ?case by (auto simp add: vec_add)
qed

text\<open>Obvious "component-pushing".\<close>

lemma vec_component [simp]: "vec x $ i = x"
  by vector

lemma vector_mult_component [simp]: "(x * y)$i = x$i * y$i"
  by vector

lemma vector_smult_component [simp]: "(c *s y)$i = c * (y$i)"
  by vector

lemma cond_component: "(if b then x else y)$i = (if b then x$i else y$i)" by vector

lemmas\<^marker>\<open>tag unimportant\<close> vector_component =
  vec_component vector_add_component vector_mult_component
  vector_smult_component vector_minus_component vector_uminus_component
  vector_scaleR_component cond_component

subsection\<^marker>\<open>tag unimportant\<close> \<open>Some frequently useful arithmetic lemmas over vectors\<close>

instance vec :: (semigroup_mult, finite) semigroup_mult
  by standard (vector mult.assoc)

instance vec :: (monoid_mult, finite) monoid_mult
  by standard vector+

instance vec :: (ab_semigroup_mult, finite) ab_semigroup_mult
  by standard (vector mult.commute)

instance vec :: (comm_monoid_mult, finite) comm_monoid_mult
  by standard vector

instance vec :: (semiring, finite) semiring
  by standard (vector field_simps)+

instance vec :: (semiring_0, finite) semiring_0
  by standard (vector field_simps)+
instance vec :: (semiring_1, finite) semiring_1
  by standard vector
instance vec :: (comm_semiring, finite) comm_semiring
  by standard (vector field_simps)+

instance vec :: (comm_semiring_0, finite) comm_semiring_0 ..
instance vec :: (semiring_0_cancel, finite) semiring_0_cancel ..
instance vec :: (comm_semiring_0_cancel, finite) comm_semiring_0_cancel ..
instance vec :: (ring, finite) ring ..
instance vec :: (semiring_1_cancel, finite) semiring_1_cancel ..
instance vec :: (comm_semiring_1, finite) comm_semiring_1 ..

instance vec :: (ring_1, finite) ring_1 ..

instance vec :: (real_algebra, finite) real_algebra
  by standard (simp_all add: vec_eq_iff)

instance vec :: (real_algebra_1, finite) real_algebra_1 ..

lemma of_nat_index: "(of_nat n :: 'a::semiring_1 ^'n)$i = of_nat n"
proof (induct n)
  case 0
  then show ?case by vector
next
  case Suc
  then show ?case by vector
qed

lemma one_index [simp]: "(1 :: 'a :: one ^ 'n) $ i = 1"
  by vector

lemma neg_one_index [simp]: "(- 1 :: 'a :: {one, uminus} ^ 'n) $ i = - 1"
  by vector

instance vec :: (semiring_char_0, finite) semiring_char_0
proof
  fix m n :: nat
  show "inj (of_nat :: nat \<Rightarrow> 'a ^ 'b)"
    by (auto intro!: injI simp add: vec_eq_iff of_nat_index)
qed

instance vec :: (numeral, finite) numeral ..
instance vec :: (semiring_numeral, finite) semiring_numeral ..

lemma numeral_index [simp]: "numeral w $ i = numeral w"
  by (induct w) (simp_all only: numeral.simps vector_add_component one_index)

lemma neg_numeral_index [simp]: "- numeral w $ i = - numeral w"
  by (simp only: vector_uminus_component numeral_index)

instance vec :: (comm_ring_1, finite) comm_ring_1 ..
instance vec :: (ring_char_0, finite) ring_char_0 ..

lemma vector_smult_assoc: "a *s (b *s x) = ((a::'a::semigroup_mult) * b) *s x"
  by (vector mult.assoc)
lemma vector_sadd_rdistrib: "((a::'a::semiring) + b) *s x = a *s x + b *s x"
  by (vector field_simps)
lemma vector_add_ldistrib: "(c::'a::semiring) *s (x + y) = c *s x + c *s y"
  by (vector field_simps)
lemma vector_smult_lzero[simp]: "(0::'a::mult_zero) *s x = 0" by vector
lemma vector_smult_lid[simp]: "(1::'a::monoid_mult) *s x = x" by vector
lemma vector_ssub_ldistrib: "(c::'a::ring) *s (x - y) = c *s x - c *s y"
  by (vector field_simps)
lemma vector_smult_rneg: "(c::'a::ring) *s -x = -(c *s x)" by vector
lemma vector_smult_lneg: "- (c::'a::ring) *s x = -(c *s x)" by vector
lemma vector_sneg_minus1: "-x = (-1::'a::ring_1) *s x" by vector
lemma vector_smult_rzero[simp]: "c *s 0 = (0::'a::mult_zero ^ 'n)" by vector
lemma vector_sub_rdistrib: "((a::'a::ring) - b) *s x = a *s x - b *s x"
  by (vector field_simps)

lemma vec_eq[simp]: "(vec m = vec n) \<longleftrightarrow> (m = n)"
  by (simp add: vec_eq_iff)

lemma Vector_Spaces_linear_vec [simp]: "Vector_Spaces.linear (*) vector_scalar_mult vec"
  by unfold_locales (vector algebra_simps)+

lemma vector_mul_eq_0[simp]: "(a *s x = 0) \<longleftrightarrow> a = (0::'a::idom) \<or> x = 0"
  by vector

lemma vector_mul_lcancel[simp]: "a *s x = a *s y \<longleftrightarrow> a = (0::'a::field) \<or> x = y"
  by (metis eq_iff_diff_eq_0 vector_mul_eq_0 vector_ssub_ldistrib)

lemma vector_mul_rcancel[simp]: "a *s x = b *s x \<longleftrightarrow> (a::'a::field) = b \<or> x = 0"
  by (subst eq_iff_diff_eq_0, subst vector_sub_rdistrib [symmetric]) simp

lemma scalar_mult_eq_scaleR [abs_def]: "c *s x = c *\<^sub>R x"
  unfolding scaleR_vec_def vector_scalar_mult_def by simp

lemma dist_mul[simp]: "dist (c *s x) (c *s y) = \<bar>c\<bar> * dist x y"
  unfolding dist_norm scalar_mult_eq_scaleR
  unfolding scaleR_right_diff_distrib[symmetric] by simp

lemma sum_component [simp]:
  fixes f:: " 'a \<Rightarrow> ('b::comm_monoid_add) ^'n"
  shows "(sum f S)$i = sum (\<lambda>x. (f x)$i) S"
proof (cases "finite S")
  case True
  then show ?thesis by induct simp_all
next
  case False
  then show ?thesis by simp
qed

lemma sum_eq: "sum f S = (\<chi> i. sum (\<lambda>x. (f x)$i ) S)"
  by (simp add: vec_eq_iff)

lemma sum_cmul:
  fixes f:: "'c \<Rightarrow> ('a::semiring_1)^'n"
  shows "sum (\<lambda>x. c *s f x) S = c *s sum f S"
  by (simp add: vec_eq_iff sum_distrib_left)

lemma linear_vec [simp]: "linear vec"
  using Vector_Spaces_linear_vec
  by unfold_locales (vector algebra_simps)+

subsection \<open>Matrix operations\<close>

text\<open>Matrix notation. NB: an MxN matrix is of type \<^typ>\<open>'a^'n^'m\<close>, not \<^typ>\<open>'a^'m^'n\<close>\<close>

definition\<^marker>\<open>tag important\<close> map_matrix::"('a \<Rightarrow> 'b) \<Rightarrow> (('a, 'i::finite)vec, 'j::finite) vec \<Rightarrow> (('b, 'i)vec, 'j) vec" where
  "map_matrix f x = (\<chi> i j. f (x $ i $ j))"

lemma nth_map_matrix[simp]: "map_matrix f x $ i $ j = f (x $ i $ j)"
  by (simp add: map_matrix_def)

definition\<^marker>\<open>tag important\<close> matrix_matrix_mult :: "('a::semiring_1) ^'n^'m \<Rightarrow> 'a ^'p^'n \<Rightarrow> 'a ^ 'p ^'m"
    (infixl "**" 70)
  where "m ** m' == (\<chi> i j. sum (\<lambda>k. ((m$i)$k) * ((m'$k)$j)) (UNIV :: 'n set)) ::'a ^ 'p ^'m"

definition\<^marker>\<open>tag important\<close> matrix_vector_mult :: "('a::semiring_1) ^'n^'m \<Rightarrow> 'a ^'n \<Rightarrow> 'a ^ 'm"
    (infixl "*v" 70)
  where "m *v x \<equiv> (\<chi> i. sum (\<lambda>j. ((m$i)$j) * (x$j)) (UNIV ::'n set)) :: 'a^'m"

definition\<^marker>\<open>tag important\<close> vector_matrix_mult :: "'a ^ 'm \<Rightarrow> ('a::semiring_1) ^'n^'m \<Rightarrow> 'a ^'n "
    (infixl "v*" 70)
  where "v v* m == (\<chi> j. sum (\<lambda>i. ((m$i)$j) * (v$i)) (UNIV :: 'm set)) :: 'a^'n"

definition\<^marker>\<open>tag unimportant\<close> "(mat::'a::zero => 'a ^'n^'n) k = (\<chi> i j. if i = j then k else 0)"
definition\<^marker>\<open>tag unimportant\<close> transpose where
  "(transpose::'a^'n^'m \<Rightarrow> 'a^'m^'n) A = (\<chi> i j. ((A$j)$i))"
definition\<^marker>\<open>tag unimportant\<close> "(row::'m => 'a ^'n^'m \<Rightarrow> 'a ^'n) i A = (\<chi> j. ((A$i)$j))"
definition\<^marker>\<open>tag unimportant\<close> "(column::'n =>'a^'n^'m =>'a^'m) j A = (\<chi> i. ((A$i)$j))"
definition\<^marker>\<open>tag unimportant\<close> "rows(A::'a^'n^'m) = { row i A | i. i \<in> (UNIV :: 'm set)}"
definition\<^marker>\<open>tag unimportant\<close> "columns(A::'a^'n^'m) = { column i A | i. i \<in> (UNIV :: 'n set)}"

lemma times0_left [simp]: "(0::'a::semiring_1^'n^'m) ** (A::'a ^'p^'n) = 0"
  by (simp add: matrix_matrix_mult_def zero_vec_def)

lemma times0_right [simp]: "(A::'a::semiring_1^'n^'m) ** (0::'a ^'p^'n) = 0"
  by (simp add: matrix_matrix_mult_def zero_vec_def)

lemma mat_0[simp]: "mat 0 = 0" by (vector mat_def)
lemma matrix_add_ldistrib: "(A ** (B + C)) = (A ** B) + (A ** C)"
  by (vector matrix_matrix_mult_def sum.distrib[symmetric] field_simps)

lemma matrix_mul_lid [simp]:
  fixes A :: "'a::semiring_1 ^ 'm ^ 'n"
  shows "mat 1 ** A = A"
  unfolding matrix_matrix_mult_def mat_def
  by (auto simp: if_distrib if_distribR sum.delta'[OF finite] cong: if_cong)

lemma matrix_mul_rid [simp]:
  fixes A :: "'a::semiring_1 ^ 'm ^ 'n"
  shows "A ** mat 1 = A"
  unfolding matrix_matrix_mult_def mat_def
  by (auto simp: if_distrib if_distribR sum.delta'[OF finite] cong: if_cong)

proposition matrix_mul_assoc: "A ** (B ** C) = (A ** B) ** C"
  apply (vector matrix_matrix_mult_def sum_distrib_left sum_distrib_right mult.assoc)
  apply (subst sum.swap)
  apply simp
  done

proposition matrix_vector_mul_assoc: "A *v (B *v x) = (A ** B) *v x"
  apply (vector matrix_matrix_mult_def matrix_vector_mult_def
    sum_distrib_left sum_distrib_right mult.assoc)
  apply (subst sum.swap)
  apply simp
  done

proposition scalar_matrix_assoc:
  fixes A :: "('a::real_algebra_1)^'m^'n"
  shows "k *\<^sub>R (A ** B) = (k *\<^sub>R A) ** B"
  by (simp add: matrix_matrix_mult_def sum_distrib_left mult_ac vec_eq_iff scaleR_sum_right)

proposition matrix_scalar_ac:
  fixes A :: "('a::real_algebra_1)^'m^'n"
  shows "A ** (k *\<^sub>R B) = k *\<^sub>R A ** B"
  by (simp add: matrix_matrix_mult_def sum_distrib_left mult_ac vec_eq_iff)

lemma matrix_vector_mul_lid [simp]: "mat 1 *v x = (x::'a::semiring_1 ^ 'n)"
  apply (vector matrix_vector_mult_def mat_def)
  apply (simp add: if_distrib if_distribR cong del: if_weak_cong)
  done

lemma matrix_transpose_mul:
    "transpose(A ** B) = transpose B ** transpose (A::'a::comm_semiring_1^_^_)"
  by (simp add: matrix_matrix_mult_def transpose_def vec_eq_iff mult.commute)

lemma matrix_mult_transpose_dot_column:
  shows "transpose A ** A = (\<chi> i j. inner (column i A) (column j A))"
  by (simp add: matrix_matrix_mult_def vec_eq_iff transpose_def column_def inner_vec_def)

lemma matrix_mult_transpose_dot_row:
  shows "A ** transpose A = (\<chi> i j. inner (row i A) (row j A))"
  by (simp add: matrix_matrix_mult_def vec_eq_iff transpose_def row_def inner_vec_def)

lemma matrix_eq:
  fixes A B :: "'a::semiring_1 ^ 'n ^ 'm"
  shows "A = B \<longleftrightarrow> (\<forall>x. A *v x = B *v x)" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs
  then show ?lhs
    apply (subst vec_eq_iff)
    apply (clarsimp simp add: matrix_vector_mult_def if_distrib if_distribR vec_eq_iff cong: if_cong)
    apply (erule_tac x="axis ia 1" in allE)
    apply (erule_tac x="i" in allE)
    apply (auto simp add: if_distrib if_distribR axis_def
        sum.delta[OF finite] cong del: if_weak_cong)
    done
qed auto

lemma matrix_vector_mul_component: "(A *v x)$k = inner (A$k) x"
  by (simp add: matrix_vector_mult_def inner_vec_def)

lemma dot_lmul_matrix: "inner ((x::real ^_) v* A) y = inner x (A *v y)"
  apply (simp add: inner_vec_def matrix_vector_mult_def vector_matrix_mult_def sum_distrib_right sum_distrib_left ac_simps)
  apply (subst sum.swap)
  apply simp
  done

lemma transpose_mat [simp]: "transpose (mat n) = mat n"
  by (vector transpose_def mat_def)

lemma transpose_transpose [simp]: "transpose(transpose A) = A"
  by (vector transpose_def)

lemma row_transpose [simp]: "row i (transpose A) = column i A"
  by (simp add: row_def column_def transpose_def vec_eq_iff)

lemma column_transpose [simp]: "column i (transpose A) = row i A"
  by (simp add: row_def column_def transpose_def vec_eq_iff)

lemma rows_transpose [simp]: "rows(transpose A) = columns A"
  by (auto simp add: rows_def columns_def intro: set_eqI)

lemma columns_transpose [simp]: "columns(transpose A) = rows A"
  by (metis transpose_transpose rows_transpose)

lemma transpose_scalar: "transpose (k *\<^sub>R A) = k *\<^sub>R transpose A"
  unfolding transpose_def
  by (simp add: vec_eq_iff)

lemma transpose_iff [iff]: "transpose A = transpose B \<longleftrightarrow> A = B"
  by (metis transpose_transpose)

lemma matrix_mult_sum:
  "(A::'a::comm_semiring_1^'n^'m) *v x = sum (\<lambda>i. (x$i) *s column i A) (UNIV:: 'n set)"
  by (simp add: matrix_vector_mult_def vec_eq_iff column_def mult.commute)

lemma vector_componentwise:
  "(x::'a::ring_1^'n) = (\<chi> j. \<Sum>i\<in>UNIV. (x$i) * (axis i 1 :: 'a^'n) $ j)"
  by (simp add: axis_def if_distrib sum.If_cases vec_eq_iff)

lemma basis_expansion: "sum (\<lambda>i. (x$i) *s axis i 1) UNIV = (x::('a::ring_1) ^'n)"
  by (auto simp add: axis_def vec_eq_iff if_distrib sum.If_cases cong del: if_weak_cong)

text\<open>Correspondence between matrices and linear operators.\<close>

definition\<^marker>\<open>tag important\<close> matrix :: "('a::{plus,times, one, zero}^'m \<Rightarrow> 'a ^ 'n) \<Rightarrow> 'a^'m^'n"
  where "matrix f = (\<chi> i j. (f(axis j 1))$i)"

lemma matrix_id_mat_1: "matrix id = mat 1"
  by (simp add: mat_def matrix_def axis_def)

lemma matrix_scaleR: "(matrix ((*\<^sub>R) r)) = mat r"
  by (simp add: mat_def matrix_def axis_def if_distrib cong: if_cong)

lemma matrix_vector_mul_linear[intro, simp]: "linear (\<lambda>x. A *v (x::'a::real_algebra_1 ^ _))"
  by (simp add: linear_iff matrix_vector_mult_def vec_eq_iff field_simps sum_distrib_left
      sum.distrib scaleR_right.sum)

lemma vector_matrix_left_distrib [algebra_simps]:
  shows "(x + y) v* A = x v* A + y v* A"
  unfolding vector_matrix_mult_def
  by (simp add: algebra_simps sum.distrib vec_eq_iff)

lemma matrix_vector_right_distrib [algebra_simps]:
  "A *v (x + y) = A *v x + A *v y"
  by (vector matrix_vector_mult_def sum.distrib distrib_left)

lemma matrix_vector_mult_diff_distrib [algebra_simps]:
  fixes A :: "'a::ring_1^'n^'m"
  shows "A *v (x - y) = A *v x - A *v y"
  by (vector matrix_vector_mult_def sum_subtractf right_diff_distrib)

lemma matrix_vector_mult_scaleR[algebra_simps]:
  fixes A :: "real^'n^'m"
  shows "A *v (c *\<^sub>R x) = c *\<^sub>R (A *v x)"
  using linear_iff matrix_vector_mul_linear by blast

lemma matrix_vector_mult_0_right [simp]: "A *v 0 = 0"
  by (simp add: matrix_vector_mult_def vec_eq_iff)

lemma matrix_vector_mult_0 [simp]: "0 *v w = 0"
  by (simp add: matrix_vector_mult_def vec_eq_iff)

lemma matrix_vector_mult_add_rdistrib [algebra_simps]:
  "(A + B) *v x = (A *v x) + (B *v x)"
  by (vector matrix_vector_mult_def sum.distrib distrib_right)

lemma matrix_vector_mult_diff_rdistrib [algebra_simps]:
  fixes A :: "'a :: ring_1^'n^'m"
  shows "(A - B) *v x = (A *v x) - (B *v x)"
  by (vector matrix_vector_mult_def sum_subtractf left_diff_distrib)

lemma matrix_vector_column:
  "(A::'a::comm_semiring_1^'n^_) *v x = sum (\<lambda>i. (x$i) *s ((transpose A)$i)) (UNIV:: 'n set)"
  by (simp add: matrix_vector_mult_def transpose_def vec_eq_iff mult.commute)

subsection\<open>Inverse matrices  (not necessarily square)\<close>

definition\<^marker>\<open>tag important\<close>
  "invertible(A::'a::semiring_1^'n^'m) \<longleftrightarrow> (\<exists>A'::'a^'m^'n. A ** A' = mat 1 \<and> A' ** A = mat 1)"

definition\<^marker>\<open>tag important\<close>
  "matrix_inv(A:: 'a::semiring_1^'n^'m) =
    (SOME A'::'a^'m^'n. A ** A' = mat 1 \<and> A' ** A = mat 1)"

lemma inj_matrix_vector_mult:
  fixes A::"'a::field^'n^'m"
  assumes "invertible A"
  shows "inj ((*v) A)"
  by (metis assms inj_on_inverseI invertible_def matrix_vector_mul_assoc matrix_vector_mul_lid)

lemma scalar_invertible:
  fixes A :: "('a::real_algebra_1)^'m^'n"
  assumes "k \<noteq> 0" and "invertible A"
  shows "invertible (k *\<^sub>R A)"
proof -
  obtain A' where "A ** A' = mat 1" and "A' ** A = mat 1"
    using assms unfolding invertible_def by auto
  with \<open>k \<noteq> 0\<close>
  have "(k *\<^sub>R A) ** ((1/k) *\<^sub>R A') = mat 1" "((1/k) *\<^sub>R A') ** (k *\<^sub>R A) = mat 1"
    by (simp_all add: assms matrix_scalar_ac)
  thus "invertible (k *\<^sub>R A)"
    unfolding invertible_def by auto
qed

proposition scalar_invertible_iff:
  fixes A :: "('a::real_algebra_1)^'m^'n"
  assumes "k \<noteq> 0" and "invertible A"
  shows "invertible (k *\<^sub>R A) \<longleftrightarrow> k \<noteq> 0 \<and> invertible A"
  by (simp add: assms scalar_invertible)

lemma vector_transpose_matrix [simp]: "x v* transpose A = A *v x"
  unfolding transpose_def vector_matrix_mult_def matrix_vector_mult_def
  by simp

lemma transpose_matrix_vector [simp]: "transpose A *v x = x v* A"
  unfolding transpose_def vector_matrix_mult_def matrix_vector_mult_def
  by simp

lemma vector_scalar_commute:
  fixes A :: "'a::{field}^'m^'n"
  shows "A *v (c *s x) = c *s (A *v x)"
  by (simp add: vector_scalar_mult_def matrix_vector_mult_def mult_ac sum_distrib_left)

lemma scalar_vector_matrix_assoc:
  fixes k :: "'a::{field}" and x :: "'a::{field}^'n" and A :: "'a^'m^'n"
  shows "(k *s x) v* A = k *s (x v* A)"
  by (metis transpose_matrix_vector vector_scalar_commute)

lemma vector_matrix_mult_0 [simp]: "0 v* A = 0"
  unfolding vector_matrix_mult_def by (simp add: zero_vec_def)

lemma vector_matrix_mult_0_right [simp]: "x v* 0 = 0"
  unfolding vector_matrix_mult_def by (simp add: zero_vec_def)

lemma vector_matrix_mul_rid [simp]:
  fixes v :: "('a::semiring_1)^'n"
  shows "v v* mat 1 = v"
  by (metis matrix_vector_mul_lid transpose_mat vector_transpose_matrix)

lemma scaleR_vector_matrix_assoc:
  fixes k :: real and x :: "real^'n" and A :: "real^'m^'n"
  shows "(k *\<^sub>R x) v* A = k *\<^sub>R (x v* A)"
  by (metis matrix_vector_mult_scaleR transpose_matrix_vector)

proposition vector_scaleR_matrix_ac:
  fixes k :: real and x :: "real^'n" and A :: "real^'m^'n"
  shows "x v* (k *\<^sub>R A) = k *\<^sub>R (x v* A)"
proof -
  have "x v* (k *\<^sub>R A) = (k *\<^sub>R x) v* A"
    unfolding vector_matrix_mult_def
    by (simp add: algebra_simps)
  with scaleR_vector_matrix_assoc
  show "x v* (k *\<^sub>R A) = k *\<^sub>R (x v* A)"
    by auto
qed

end


(*  Title:      HOL/Word/Bit_Comparison.thy
    Author:     Stefan Berghofer
    Copyright:  secunet Security Networks AG

Comparison on bit operations on integers.
*)

theory Bit_Comparison
imports Bits_Int
begin

lemma AND_lower [simp]:
  fixes x :: int and y :: int
  assumes "0 \<le> x"
  shows "0 \<le> x AND y"
  using assms
proof (induct x arbitrary: y rule: bin_induct)
  case (3 bin bit)
  show ?case
  proof (cases y rule: bin_exhaust)
    case (1 bin' bit')
    from 3 have "0 \<le> bin"
      by (cases bit) (simp_all add: Bit_def)
    then have "0 \<le> bin AND bin'" by (rule 3)
    with 1 show ?thesis
      by simp (simp add: Bit_def)
  qed
next
  case 2
  then show ?case by (simp only: Min_def)
qed simp

lemma OR_lower [simp]:
  fixes x :: int and y :: int
  assumes "0 \<le> x" "0 \<le> y"
  shows "0 \<le> x OR y"
  using assms
proof (induct x arbitrary: y rule: bin_induct)
  case (3 bin bit)
  show ?case
  proof (cases y rule: bin_exhaust)
    case (1 bin' bit')
    from 3 have "0 \<le> bin"
      by (cases bit) (simp_all add: Bit_def)
    moreover from 1 3 have "0 \<le> bin'"
      by (cases bit') (simp_all add: Bit_def)
    ultimately have "0 \<le> bin OR bin'" by (rule 3)
    with 1 show ?thesis
      by simp (simp add: Bit_def)
  qed
qed simp_all

lemma XOR_lower [simp]:
  fixes x :: int and y :: int
  assumes "0 \<le> x" "0 \<le> y"
  shows "0 \<le> x XOR y"
  using assms
proof (induct x arbitrary: y rule: bin_induct)
  case (3 bin bit)
  show ?case
  proof (cases y rule: bin_exhaust)
    case (1 bin' bit')
    from 3 have "0 \<le> bin"
      by (cases bit) (simp_all add: Bit_def)
    moreover from 1 3 have "0 \<le> bin'"
      by (cases bit') (simp_all add: Bit_def)
    ultimately have "0 \<le> bin XOR bin'" by (rule 3)
    with 1 show ?thesis
      by simp (simp add: Bit_def)
  qed
next
  case 2
  then show ?case by (simp only: Min_def)
qed simp

lemma AND_upper1 [simp]:
  fixes x :: int and y :: int
  assumes "0 \<le> x"
  shows "x AND y \<le> x"
  using assms
proof (induct x arbitrary: y rule: bin_induct)
  case (3 bin bit)
  show ?case
  proof (cases y rule: bin_exhaust)
    case (1 bin' bit')
    from 3 have "0 \<le> bin"
      by (cases bit) (simp_all add: Bit_def)
    then have "bin AND bin' \<le> bin" by (rule 3)
    with 1 show ?thesis
      by simp (simp add: Bit_def)
  qed
next
  case 2
  then show ?case by (simp only: Min_def)
qed simp

lemmas AND_upper1' [simp] = order_trans [OF AND_upper1]
lemmas AND_upper1'' [simp] = order_le_less_trans [OF AND_upper1]

lemma AND_upper2 [simp]:
  fixes x :: int and y :: int
  assumes "0 \<le> y"
  shows "x AND y \<le> y"
  using assms
proof (induct y arbitrary: x rule: bin_induct)
  case (3 bin bit)
  show ?case
  proof (cases x rule: bin_exhaust)
    case (1 bin' bit')
    from 3 have "0 \<le> bin"
      by (cases bit) (simp_all add: Bit_def)
    then have "bin' AND bin \<le> bin" by (rule 3)
    with 1 show ?thesis
      by simp (simp add: Bit_def)
  qed
next
  case 2
  then show ?case by (simp only: Min_def)
qed simp

lemmas AND_upper2' [simp] = order_trans [OF AND_upper2]
lemmas AND_upper2'' [simp] = order_le_less_trans [OF AND_upper2]

lemma OR_upper:
  fixes x :: int and y :: int
  assumes "0 \<le> x" "x < 2 ^ n" "y < 2 ^ n"
  shows "x OR y < 2 ^ n"
  using assms
proof (induct x arbitrary: y n rule: bin_induct)
  case (3 bin bit)
  show ?case
  proof (cases y rule: bin_exhaust)
    case (1 bin' bit')
    show ?thesis
    proof (cases n)
      case 0
      with 3 have "bin BIT bit = 0" by simp
      then have "bin = 0" and "\<not> bit"
        by (auto simp add: Bit_def split: if_splits) arith
      then show ?thesis using 0 1 \<open>y < 2 ^ n\<close>
        by simp
    next
      case (Suc m)
      from 3 have "0 \<le> bin"
        by (cases bit) (simp_all add: Bit_def)
      moreover from 3 Suc have "bin < 2 ^ m"
        by (cases bit) (simp_all add: Bit_def)
      moreover from 1 3 Suc have "bin' < 2 ^ m"
        by (cases bit') (simp_all add: Bit_def)
      ultimately have "bin OR bin' < 2 ^ m" by (rule 3)
      with 1 Suc show ?thesis
        by simp (simp add: Bit_def)
    qed
  qed
qed simp_all

lemma XOR_upper:
  fixes x :: int and y :: int
  assumes "0 \<le> x" "x < 2 ^ n" "y < 2 ^ n"
  shows "x XOR y < 2 ^ n"
  using assms
proof (induct x arbitrary: y n rule: bin_induct)
  case (3 bin bit)
  show ?case
  proof (cases y rule: bin_exhaust)
    case (1 bin' bit')
    show ?thesis
    proof (cases n)
      case 0
      with 3 have "bin BIT bit = 0" by simp
      then have "bin = 0" and "\<not> bit"
        by (auto simp add: Bit_def split: if_splits) arith
      then show ?thesis using 0 1 \<open>y < 2 ^ n\<close>
        by simp
    next
      case (Suc m)
      from 3 have "0 \<le> bin"
        by (cases bit) (simp_all add: Bit_def)
      moreover from 3 Suc have "bin < 2 ^ m"
        by (cases bit) (simp_all add: Bit_def)
      moreover from 1 3 Suc have "bin' < 2 ^ m"
        by (cases bit') (simp_all add: Bit_def)
      ultimately have "bin XOR bin' < 2 ^ m" by (rule 3)
      with 1 Suc show ?thesis
        by simp (simp add: Bit_def)
    qed
  qed
next
  case 2
  then show ?case by (simp only: Min_def)
qed simp

end


theory HybridSC2 imports Main ListSet
begin

datatype 'a hybr_form
  =  Pro 'a (\<open>PRO _\<close> [999] 999)
  | Nom nat (\<open>NOM _\<close> [998] 998)
  | Neg \<open>'a hybr_form\<close> (\<open>NOT _\<close> [900] 900)
  | Con \<open>'a hybr_form\<close> \<open>'a hybr_form\<close> (infixl "AND" 300)
  | Sat nat \<open>'a hybr_form\<close> (\<open>AT _ _\<close> [899]  899)
  | Pos \<open>'a hybr_form\<close> (\<open>\<diamond> _\<close> [800] 800)

(*find the maximal nominal in a list of nominals, and return one bigger than that*)
definition lmax :: \<open>nat list \<Rightarrow> nat\<close> where \<open>lmax N \<equiv> foldr (\<lambda> x i. max x i) N 0\<close>

lemma lmax_max: "member n N \<Longrightarrow> n \<le> lmax N"
proof (induct N)
  case (Cons a N)
  then have \<open>a = n \<or> member n N\<close>
      by (metis member.simps(2))
  then show ?case
    using Cons lmax_def by auto
qed simp

(*return nominal not in a set of nominals*)
abbreviation fresh where \<open>fresh N \<equiv> Suc (lmax N)\<close>

lemma fresh_new: "fresh N = n \<Longrightarrow> \<not> member n N"
  using lmax_max by fastforce

(*get a set of all used nominal, for different formula representations*)
primrec nominalsForm where
  \<open>nominalsForm (Pro a) = []\<close> |
  \<open>nominalsForm (Nom n) = [n]\<close> |
  \<open>nominalsForm (Neg p) = nominalsForm p\<close> |
  \<open>nominalsForm (Con p1 p2) = union (nominalsForm p1) (nominalsForm p2)\<close> |
  \<open>nominalsForm (Sat n p) = add n (nominalsForm p)\<close> |
  \<open>nominalsForm (Pos p) = nominalsForm p\<close>

primrec nominalsForms where
  \<open>nominalsForms [] = []\<close> |
  \<open>nominalsForms (x # xs) = union (nominalsForm x) (nominalsForms xs)\<close>

fun nominalsNN where
  \<open>nominalsNN [] = []\<close> |
  \<open>nominalsNN ((n1,n2) # NN) = add n1 (add n2 (nominalsNN NN))\<close>

fun nominalsNA where
  \<open>nominalsNA [] = []\<close> |
  \<open>nominalsNA ((n,a) # NA) = add n (nominalsNA NA)\<close>

fun nominalsNP where
  \<open>nominalsNP [] = []\<close> |
  \<open>nominalsNP ((n,p) # NP) = add n (union (nominalsForm p) (nominalsNP NP))\<close>

fun nominalsNNSP where
  \<open>nominalsNNSP [] = []\<close> |
  \<open>nominalsNNSP ((n,ns,p) # NNSP) = nominalsNNSP NNSP U add n (ns U nominalsForm p)\<close>

lemma form_is_set: \<open>is_set (nominalsForm P)\<close>
  apply (induct P)
       apply simp_all
   apply (simp add: union_is_set)
  by (simp add: add_def)

lemma forms_is_set: \<open>is_set (nominalsForms ps)\<close>
  by (induct ps) (simp_all add: form_is_set union_is_set)

lemma NN_is_set: \<open>is_set (nominalsNN NN)\<close>
  apply (induct NN)
   apply simp
  by (smt (verit) add_def is_set.simps(2) nominalsNN.simps(2) old.prod.exhaust)

lemma NA_is_set: \<open>is_set (nominalsNA NA)\<close>
  apply (induct NA)
   apply simp
  by (metis nominalsNA.simps(2) old.prod.exhaust union.simps(1) union.simps(2) union_is_set)

lemma NP_is_set: \<open>is_set (nominalsNP NP)\<close>
  apply (induct NP)
   apply simp
  by (metis add_is_set form_is_set list.discI nominalsNP.elims union_is_set)

lemma NNSP_is_set: \<open>is_set (nominalsNNSP NNSP)\<close>
proof (induct NNSP)
  case Nil
  then show ?case by simp
next
  case (Cons a NNSP)
  then show ?case
    by (metis list.discI list.inject nominalsNNSP.elims union_is_set)
qed

(*merge functions replaces all occurences of a nominal with another.
Used when two nominals are found to be equal*)
fun mergeNS where
  \<open>mergeNS NS na nb = map (\<lambda> n. if n = na then nb else n) NS\<close>

fun mergeNN where
  \<open>mergeNN [] na nb = []\<close> |
  \<open>mergeNN ((n1,n2) # NN) na nb = (
    let n3 = (if n1 = na then nb else n1) in
    let n4 = (if n2 = na then nb else n2) in
    (n3,n4) # (mergeNN NN na nb))\<close>

fun mergeNA where
  \<open>mergeNA [] na nb = []\<close> |
  \<open>mergeNA ((n1,a) # NA) na nb = (if n1 = na then nb else n1, a) # (mergeNA NA na nb)\<close>

fun mergeP where
  \<open>mergeP (Pro a) na nb = Pro a\<close> |
  \<open>mergeP (Nom n) na nb = Nom (if n = na then nb else n)\<close> |
  \<open>mergeP (Neg p) na nb = Neg (mergeP p na nb)\<close> |
  \<open>mergeP (Con p1 p2) na nb = Con (mergeP p1 na nb) (mergeP p2 na nb)\<close> |
  \<open>mergeP (Sat n p) na nb = Sat (if n = na then nb else n) (mergeP p na nb)\<close> |
  \<open>mergeP (Pos p) na nb = Pos (mergeP p na nb)\<close>

fun mergeNP where
  \<open>mergeNP [] na nb = []\<close> |
  \<open>mergeNP ((n,p) # NP) na nb = (if n = na then nb else n, mergeP p na nb) # (mergeNP NP na nb)\<close>

fun mergeNNSP where
  \<open>mergeNNSP [] na nb = []\<close> |
  \<open>mergeNNSP ((n,ns,p) # R) na nb =
    (if n = na then nb else n, mergeNS ns na nb, mergeP p na nb) # (mergeNNSP R na nb)\<close>

fun clear where
  \<open>clear [] = []\<close> |
  \<open>clear ((n,ns,p) # R) = (n,[],p) # clear R\<close>

fun saturate' where
  \<open>saturate' R' [] ns = None\<close> |
  \<open>saturate' R' ((n,ms,p) # R) ns = (
    case remove ns ms of
      []      \<Rightarrow> saturate' (R' @ [(n,ms,p)]) R ns
    | (m # _) \<Rightarrow> Some (n,m,p,clear (R' @ R),R' @ [(n,m # ms,p)] @ R))\<close>

abbreviation saturate where \<open>saturate R ns \<equiv> saturate' [] R ns\<close>

lemma sat_empty: \<open>saturate [] ns = None\<close>
  by (simp)

(*Check if any of the pairs in a list contains two of the same element*)
fun reflect where
  \<open>reflect [] = False\<close> |
  \<open>reflect ((n1,n2) # B) = (n1 = n2 \<or> reflect B)\<close>

lemma reflect_iff[iff]: \<open>reflect nn \<longleftrightarrow> (\<exists> n. (n,n) \<in> set nn)\<close>
  apply (induct nn)
   apply simp
  by (metis list.set_intros(1) list.set_intros(2) reflect.simps(2) set_ConsD surj_pair)

abbreviation ns_0 where \<open>ns_0 LA RA RN LP RP R Q P \<equiv>
  nominalsNA LA U nominalsNA RA U nominalsNN RN U
  nominalsNN LP U nominalsNN RP U nominalsNNSP R U nominalsNP Q U nominalsNP P\<close>
context
begin
(*termination functions*)
private primrec pos_count where
  \<open>pos_count (Pro a) = 0\<close> |
  \<open>pos_count (Nom n) = 0\<close> |
  \<open>pos_count (Neg p) = pos_count p\<close> |
  \<open>pos_count (Con p1 p2) = pos_count p1 + pos_count p2\<close> |
  \<open>pos_count (Sat n p) = pos_count p\<close> |
  \<open>pos_count (Pos p) = Suc (pos_count p)\<close>

private fun pos_countNP where
  \<open>pos_countNP [] = 0\<close> |
  \<open>pos_countNP ((_,p) # NP) = pos_count p + pos_countNP NP\<close>

private fun pos_countNNSP where
  \<open>pos_countNNSP [] = 0\<close> |
  \<open>pos_countNNSP ((_,_,p) # NNSP) = pos_count p + pos_countNNSP NNSP\<close>

private fun missing' where
  \<open>missing' ms [] = 0\<close> |
  \<open>missing' ms (n # ns) = (if \<not>member n ms then Suc (missing' ms ns) else missing' ms ns)\<close>

private fun missing :: "('a \<times> nat list \<times>'b) list \<Rightarrow> nat list \<Rightarrow> nat" where
  \<open>missing [] ns = 0\<close> |
  \<open>missing ((_,ms,_) # R) ns = missing' ms ns + missing R ns\<close>

(*
----------EXPLANATION OF PARAMETERS OF ATOMIZE---------
All parameters are lists of tuples representing formulas of different types
The first element identifies the nominal at which the formula holds

LA/RA: LHS and RHS atomic non-nominal propositions. Sequent is valid if they share an element

RN: RHS nominal propositions. Sequent is valid if we have @n n. There is no LN because we process
    them immediately

LP/RP: LHS and RHS possibility relations between nominals. Sequent is valid if they share an element

R: RHS possibility formulas with potentially complex subformulas. Formulas here can be discharged
   multiple times with different witnessing nominals

Q/P: LHS and RHS complex formulas.
*)

function sv :: \<open>
  (nat \<times> 'a) list \<Rightarrow> (nat \<times> 'a) list \<Rightarrow> (nat \<times> nat) list \<Rightarrow> (nat \<times> nat) list \<Rightarrow> (nat \<times> nat) list \<Rightarrow>
  (nat \<times> (nat list) \<times> 'a hybr_form) list \<Rightarrow> (nat \<times> 'a hybr_form) list \<Rightarrow> (nat \<times> 'a hybr_form) list
  \<Rightarrow> bool\<close> where
  (*match RHS*)
  \<open>sv LA RA RN LP RP R Q ((n,Pro a) # P) =
    sv LA ((n,a) # RA) RN LP RP R Q P\<close> |

  \<open>sv LA RA RN LP RP R Q ((n1,Nom n2) # P) =
    sv LA RA ((n1,n2) # RN) LP RP R Q P\<close> |

  \<open>sv LA RA RN LP RP R Q ((n,Neg p) # P) =
    sv LA RA RN LP RP R ((n,p) # Q) P\<close> |

  \<open>sv LA RA RN LP RP R Q ((n,Con p1 p2) # P) =
    ((sv LA RA RN LP RP R Q ((n,p1) # P)) \<and> (sv LA RA RN LP RP R Q ((n,p2) # P)))\<close> |

  \<open>sv LA RA RN LP RP R Q ((n1,Sat n2 p) # P) =
    sv LA RA RN LP RP R Q ((n2,p) # P)\<close> |

  \<open>sv LA RA RN LP RP R Q ((n,Pos p) # P) =
    sv LA RA RN LP RP ((n,[],p) # R) Q P\<close>|

  (*match LHS*)
  \<open>sv LA RA RN LP RP R ((n,Pro a) # Q) [] =
    sv ((n,a) # LA) RA RN LP RP R Q []\<close> |

  \<open>sv LA RA RN LP RP R ((n1,Nom n2) # Q) [] =
    sv (mergeNA LA n1 n2) (mergeNA RA n1 n2) (mergeNN RN n1 n2)
      (mergeNN LP n1 n2) (mergeNN RP n1 n2) (mergeNNSP R n1 n2) (mergeNP Q n1 n2) []\<close> |

  \<open>sv LA RA RN LP RP R ((n,Neg p) # Q) [] =
    sv LA RA RN LP RP R Q [(n,p)]\<close> |

  \<open>sv LA RA RN LP RP R ((n,Con p1 p2) # Q) []=
    sv LA RA RN LP RP R ((n,p1) # (n,p2) # Q) []\<close> |

  \<open>sv LA RA RN LP RP R ((n1,Sat n2 p) # Q) [] =
    sv LA RA RN LP RP R ((n2,p) # Q) []\<close> |

  \<open>sv LA RA RN LP RP R ((n,Pos p) # Q) [] = (
    let nw = fresh (
      nominalsNA LA U nominalsNA RA U nominalsNN RN U nominalsNN LP U
      nominalsNN RP U nominalsNNSP R U nominalsNP ((n,Pos p) # Q))
    in (sv LA RA RN ((n,nw) # LP) RP R ((nw,p) # Q) []))\<close> |
(*-------Try all relevant assignments of nominals to possibility on RHS-----------
If no assignment can be made, check if current sequent is a tautology.
Else we can process a statement @n\<diamond>P.
  Find a nominal m to witness the statement
  Check if the sequent with @n\<diamond>P removed fulfills both @n\<diamond>m and @mP
  Lastly, try another assignment. Remember that we already tried m.*)
  \<open>sv LA RA RN LP RP R [] [] = (
      case
        saturate R (
          nominalsNA LA U nominalsNA RA U nominalsNN RN U
          nominalsNN LP U nominalsNN RP U nominalsNNSP R)
      of
        None \<Rightarrow> (common LA RA \<or> common LP RP \<or> reflect RN)
      | Some (n,m,p,R',R'') \<Rightarrow>
          (sv LA RA RN LP ((n,m) # RP) R' [] [] \<and> sv LA RA RN LP RP R' [] [(m,p)])
          \<or> sv LA RA RN LP RP R'' [] [])\<close>
  by pat_completeness simp_all
(*size definition for proving termination of sv*)
termination sorry

definition prover where
  \<open>prover p \<equiv> sv [] [] [] [] [] [] [] [(fresh (nominalsForm p),p)]\<close>

end

primrec semantics :: \<open>('c \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow>
                  (nat \<Rightarrow> 'c) \<Rightarrow> 'c \<Rightarrow> 'a hybr_form \<Rightarrow> bool\<close> where
  \<open>semantics RE V G w (Pro a) = V w a\<close> |
  \<open>semantics RE V G w (Nom n) = ((G n) = w)\<close> |
  \<open>semantics RE V G w (Neg p) = (\<not> semantics RE V G w p)\<close> |
  \<open>semantics RE V G w (Con p1 p2) = (semantics RE V G w p1 \<and> semantics RE V G w p2)\<close> |
  \<open>semantics RE V G w (Sat n p) = semantics RE V G (G n) p\<close> |
  \<open>semantics RE V G w (Pos p) = (\<exists> v. (RE w v) \<and> (semantics RE V G v p))\<close>

definition \<open>sc RE V G LA RA RN LP RP R Q P \<equiv>
  (
    (\<forall> (n,p) \<in> set Q. semantics RE V G (G n) p) \<and>
    (\<forall> (n1,n2) \<in> set LP. RE (G n1) (G n2)) \<and>
    (\<forall> (n,a) \<in> set LA. V (G n) a)
  ) \<longrightarrow> (
    (\<exists> (n,p) \<in> set P. semantics RE V G (G n) p) \<or>
    (\<exists> (n,ns,p) \<in> set R.
      (\<exists> w. RE (G n) w \<and> semantics RE V G w p)) \<or>
    (\<exists> (n1,n2) \<in> set RP. RE (G n1) (G n2)) \<or>
    (\<exists> (n1,n2) \<in> set RN. (G n1) = (G n2)) \<or>
    (\<exists> (n,a) \<in> set RA. V (G n) a)
  )\<close>

(*abbreviations*)
abbreviation Imp (infixr "THEN"  180)
  where "Imp p q \<equiv> Neg (Con p (Neg q))"

abbreviation Iff (infixr "IFF" 180)
  where "Iff p q \<equiv> Con (Imp p q) (Imp q p)"

abbreviation Dis (infixl "OR"  200)
  where "Dis p q \<equiv> Neg (Con (Neg p) (Neg q))"

abbreviation Nes (\<open>\<box> _\<close> 800)
  where "Nes p \<equiv> Neg (Pos (Neg p))"

(*tests*)
datatype atoms = A | B | C | D | E | F | G | H | I | J | K | L | M | N

(*valid tests*)
proposition \<open>prover
  (NOT ((Sat 1 (Pos (NOM 4))) AND
  (NOT (Sat 1 (Pos (NOT ((Sat 2 (Pos (NOM 3))) AND (Sat 3 (Pro A))) AND
  NOT ((Sat 2 (Pos (NOM 4))) AND (Sat 4 (Pro A))))))) AND
  (NOT (Sat 2 (Pos (Pro A))))))\<close>
  by eval

proposition \<open>prover
  (NOT ((Sat 1 (Pos (NOM 4))) AND
  (NOT (Sat 2 (Pos (Pro A)))) AND
  (NOT (Sat 1 (Pos (NOT ((Sat 2 (Pos (NOM 3))) AND (Sat 3 (Pro A))) AND
  NOT ((Sat 2 (Pos (NOM 4))) AND (Sat 4 (Pro A)))))))))\<close>
  by eval

proposition \<open>prover (
  (AT 1 NOM 4) THEN (AT 2 \<diamond> PRO A) OR ((NOT ((AT 2 \<diamond> NOM 3) AND AT 3 PRO A) AND NOT
  ((AT 2 \<diamond> NOM 4) AND AT 4 PRO A))))\<close>
  by eval

proposition \<open>prover (((Sat (1)  (Pos (Nom (2)))) AND (Sat (2) (Pro A)))
                     THEN (Sat (1) (Pos (Pro A))))\<close>
  by eval

proposition \<open>prover (NOT (NOT Pro A AND Pro A))\<close>
  by eval

proposition \<open>prover ((NOM 1 AND PRO A) THEN (AT 1 (PRO A)))\<close>
  by eval

proposition \<open>prover (Pro A THEN (Pro B IFF Pro C) THEN Pro A)\<close>
  by eval

proposition \<open>prover ((Pro A OR Pro B) AND (Pro A OR NOT Pro B) THEN (Pro A))\<close>
  by eval

proposition \<open>prover (NOT (NOT(((Pro B OR (NOT Pro C AND Pro D)) IFF (Pro E OR (Pro C THEN Pro A)))
  IFF (((Pro B OR (NOT Pro C AND Pro D)) THEN (Pro E OR
(Pro C THEN Pro A))) AND ((Pro E OR (Pro C THEN Pro A)) THEN (Pro B OR (NOT Pro C AND Pro D)))))))\<close>
  by eval

proposition \<open>prover (NOT (NOT ((Pro A AND Pro B) THEN ( ((Pro C IFF NOT Pro E) OR NOT Pro F)
THEN ((Pro A AND Pro B) OR (Pro B OR NOT Pro B)) ))
AND (Pro A OR Pro B) AND (Pro C IFF NOT Pro D)))\<close>
  by eval

proposition \<open>prover (NOT ((AT (1) (\<diamond> (NOM 2)))
             AND (AT (2) (Pro A)) AND (AT (1) (\<box> NOT Pro A))))\<close>
  by eval

proposition \<open>prover
 ((AT (1) (\<diamond>(NOM 3))) THEN
  ((AT (2) (Pro A)) OR (AT (1) (\<diamond> (AT (2) (NOT Pro A))))))\<close>
  by eval

proposition \<open>prover ((AT (1) (\<diamond> NOM 2)) AND
                     (AT (2) (\<diamond> NOM 3)) AND
                     (AT (3) (Pro A)) THEN
                     (AT (1) (\<diamond>(\<diamond> (Pro A)))))\<close>
  by eval

proposition \<open>prover ((AT (1) (\<diamond>\<diamond>\<diamond>\<diamond> Pro A)) THEN (AT (1) (\<diamond>\<diamond>\<diamond>\<diamond> Pro A)))\<close>
  by eval

proposition \<open>prover ((AT (1) (
                     (AT (2) (
                     ((\<box>((Pro A) THEN ((NOT ((Pro A) THEN ((Pro B) THEN (Pro A)))) OR (Pro B))))
                      THEN ((\<box>(Pro A)) THEN \<box> (Pro B))))))))\<close>
  by eval

proposition \<open>prover ((\<diamond> NOT PRO A) OR (\<box> PRO A))\<close>
  by eval

proposition \<open>prover ((\<diamond> PRO A) OR (NOT (\<diamond> PRO A)))\<close>
  by eval

proposition \<open>prover ((NOT (\<diamond> PRO A)) OR (\<diamond> PRO A))\<close>
  by eval

proposition \<open>prover ((AT (1) (NOT (\<diamond> NOM (1)))) THEN
                    ((AT (1) (NOM (2) AND (Pro A))) THEN
                     (AT (1) (NOT (\<diamond> NOM (2))))))\<close>
  by eval

proposition \<open>prover ((\<diamond>PRO A) THEN (\<diamond>PRO A))\<close>
  by eval

proposition \<open>prover ((PRO A) AND (AT 1 (\<diamond> NOM 2)) AND (AT 2 (\<diamond> NOM 1)) THEN (AT 1 (\<diamond>\<diamond> NOM 1)))\<close>
  by eval

proposition \<open>prover ((\<diamond> PRO A) THEN (\<diamond> PRO B) OR (\<diamond> NOT PRO B))\<close>
  by eval

proposition \<open>prover ((\<diamond> PRO A) THEN (\<diamond> NOT PRO B) OR (\<diamond> PRO B))\<close>
  by eval

proposition \<open>prover ((\<diamond> PRO A) THEN (\<diamond> (AT 2 NOT (\<diamond> NOM 1))) OR (AT 2 \<diamond> NOM 1))\<close>
  by eval

proposition \<open>prover ((\<diamond> PRO A) THEN (AT 2 \<diamond> NOM 1 ) OR (\<diamond> (AT 2 NOT (\<diamond> NOM 1))))\<close>
  by eval

(*invalid tests*)

proposition \<open>\<not>(prover (Pro A))\<close>
  by eval

proposition \<open>\<not>(prover (Con (Pro A) (Pro A)))\<close>
  by eval

proposition \<open>\<not>(prover (Con (Neg (Pro A)) (Pro A)))\<close>
  by eval

proposition \<open>\<not>(prover (Sat (1) (Con (Neg (Pro A)) (Pro A))))\<close>
  by eval

proposition \<open>\<not>(sv [] [] [] [] [] [] [(1,\<diamond> NOM 2)] [(1,\<diamond> AT 1 (NOT (\<diamond> PRO A)))])\<close>
  by eval

proposition \<open>\<not>(prover (
  NOT (Pro A AND Pro A)
  AND (Pro C THEN Pro B) AND NOT (NOT Pro E THEN (Pro C OR NOT NOT Pro D))))\<close>
  by eval

proposition \<open>\<not>(prover (
NOT (Pro A AND Pro A) AND (Pro C THEN Pro B) AND
 (AT (1) (NOT (NOT Pro E THEN (Pro C OR NOT NOT Pro D)))) AND
 (AT (2) (AT (3) (Pro C)))
))\<close>
  by eval

proposition \<open>\<not>(prover (
(\<diamond>(Pro A)) AND (\<diamond>((Pro A) AND (\<diamond>(Pro A)))) AND (\<box>((Pro A) AND (\<diamond>(Pro A)) AND
 (\<diamond>((\<diamond>(NOT (Pro A))) AND (\<box>(Pro B)))))) AND
(\<box>(NOT Pro B)) AND ((Pro A) IFF (Pro C)) AND (\<box>((Pro A) IFF (Pro C))) AND
((Pro K) OR (Pro L) OR (Pro M) OR (Pro N) OR (Pro F)) AND
((NOT Pro K) OR (NOT Pro L) OR (NOT Pro M)) AND
(\<box>\<box>\<box>((Pro K) IFF (Pro L)))
))\<close>
  by eval

proposition \<open>\<not>prover ((AT (2) (Pro A)) THEN (AT (1) (\<diamond> (AT (2) (Pro A)))))\<close>
  by eval

proposition \<open>\<not>prover ((Pro A) THEN (Sat (1) (Pro A)))\<close>
  by eval

proposition \<open>\<not>prover (AT 1 (\<diamond> ((NOT (AT 1 (\<diamond> NOM 2))) OR (PRO A OR NOT PRO A))))\<close>
  by eval

proposition \<open>\<not>prover ((\<diamond> NOT(\<diamond> PRO A)) OR \<diamond> NOT (\<diamond> PRO A))\<close>
  by eval

proposition \<open>\<not>prover (PRO A THEN \<diamond> PRO A)\<close>
  by eval

proposition \<open>\<not>prover (AT 1 (\<diamond> ((PRO A OR NOT PRO A) OR NOT (AT 1 \<diamond> NOM 2))))\<close>
  by eval

(*export
definition \<open>main \<equiv> prover (Sat 1 (Neg (Con (Pro A) (Neg (Pro A)))))\<close>
proposition main by eval
export_code main in Haskell*)

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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.*)
  theory TIP_prop_13
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun half :: "Nat => Nat" where
"half (Z) = Z"
| "half (S (Z)) = Z"
| "half (S (S z)) = S (half z)"

fun t2 :: "Nat => Nat => Nat" where
"t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

theorem property0 :
  "((half (t2 x x)) = x)"
  oops

end


(* 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.*)
  theory TIP_weird_nat_op_spec
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun times :: "Nat => Nat => Nat" where
  "times (Z) y = Z"
| "times (S z) y = plus y (times z y)"

fun op1 :: "Nat => Nat => Nat => Nat => Nat" where
  "op1 x y z x2 =
   (let fail :: Nat =
     (case z of
        Z => (case x of S x4 => op1 x4 y y x2)
        | S x3 => op1 x y x3 (S x2))
   in (case x of
         Z =>
           (case z of
              Z => x2
              | S x6 => fail)
         | S x5 => fail))"

theorem property0 :
  "((op1 a b c d) = (plus (plus (times a b) c) d))"
  oops

end


(* Author: Florian Haftmann, TU Muenchen *)

section {* Small examples for evaluation mechanisms *}

theory Eval_Examples
imports Complex_Main
begin

text {* evaluation oracle *}

lemma "True \<or> False" by eval
lemma "Suc 0 \<noteq> Suc 1" by eval
lemma "[] = ([] :: int list)" by eval
lemma "[()] = [()]" by eval
lemma "fst ([] :: nat list, Suc 0) = []" by eval

text {* normalization *}

lemma "True \<or> False" by normalization
lemma "Suc 0 \<noteq> Suc 1" by normalization
lemma "[] = ([] :: int list)" by normalization
lemma "[()] = [()]" by normalization
lemma "fst ([] :: nat list, Suc 0) = []" by normalization

text {* term evaluation *}

value "(Suc 2 + 1) * 4"

value "(Suc 2 + Suc 0) * Suc 3"

value "nat 100"

value "(10::int) \<le> 12"

value "max (2::int) 4"

value "of_int 2 / of_int 4 * (1::rat)"

value "[] :: nat list"

value "[(nat 100, ())]"

text {* a fancy datatype *}

datatype ('a, 'b) foo =
    Foo "'a\<Colon>order" 'b
  | Bla "('a, 'b) bar"
  | Dummy nat
and ('a, 'b) bar =
    Bar 'a 'b
  | Blubb "('a, 'b) foo"

value "Bla (Bar (4::nat) [Suc 0])"

end


theory Matroid_Rank_Properties
  imports Main Higher_Projective_Space_Rank_Axioms
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> In this file we introduce the basic lemmas and properties derived from our based-rank axioms
that will allow us to simplify our future proofs.
\<close>

section \<open>Proof Techniques Using Ranks\<close>

lemma matroid_ax_3_alt:
  assumes "I \<subseteq> X \<inter> Y"
  shows "rk (X \<union> Y) + rk I \<le> rk X + rk Y"
  by (metis add.commute add_le_cancel_right assms matroid_ax_2 matroid_ax_3 order_trans)

lemma rk_uniqueness:
  assumes "rk {A,B} = 2" and "rk {C,D} = 2" and "rk {A,B,M} \<le> 2" and "rk {C,D,M} \<le> 2" and
  "rk {A,B,P} \<le> 2" and "rk {C,D,P} \<le> 2" and "rk {A,B,C,D} \<ge> 3"
  shows "rk {M,P} = 1"
proof-
  have "{A,B,M} \<union> {A,B,P} = {A,B,M,P}"
    by auto
  have "rk {A,B,M,P} + rk {A,B} \<le> rk {A,B,M} + rk {A,B,P}"
    by (metis (full_types) \<open>{A, B, M} \<union> {A, B, P} = {A, B, M, P}\<close> insert_commute le_inf_iff
        matroid_ax_3_alt subset_insertI)
  then have "rk {A,B,M,P} = 2"
    by (smt Un_upper1 Un_upper2 \<open>{A, B, M} \<union> {A, B, P} = {A, B, M, P}\<close> add_diff_cancel_left'
        add_diff_cancel_right' add_mono antisym assms(1) assms(3) assms(5) le_diff_conv matroid_ax_2)
  have "{C,D,M} \<union> {C,D,P} = {C,D,M,P}"
    by auto
  have "rk {C,D,M,P} + rk {C,D} \<le> rk {C,D,M} + rk {C,D,P}"
    by (metis Un_insert_left Un_upper1 \<open>{C, D, M} \<union> {C, D, P} = {C, D, M, P}\<close> insert_is_Un le_inf_iff
        matroid_ax_3_alt)
  then have i1:"rk {C,D,M,P} + 2 \<le> 4"
    using assms(2) assms(4) assms(6)
    by linarith
  moreover have i2:"rk {C,D,M,P} \<ge> 2"
    by (metis assms(2) insertI1 insert_subset matroid_ax_2 subset_insertI)
  from i1 and i2 have "rk {C,D,M,P} = 2"
    by linarith
  have "rk {A,B,C,D,M,P} \<ge> 3"
    by (metis Un_insert_right Un_upper2 assms(7) matroid_ax_2 order_trans sup_bot.right_neutral)
  have "{A,B,M,P} \<union> {C,D,M,P} = {A,B,C,D,M,P}"
    by auto
  then have "rk {A,B,C,D,M,P} + rk {M,P} \<le> rk {A,B,M,P} + rk {C,D,M,P}"
    by (smt le_inf_iff matroid_ax_3_alt order_trans subset_insertI)
  then have i3:"rk {A,B,C,D,M,P} + rk {M,P} \<le> 4"
    using \<open>rk {A, B, M, P} = 2\<close> \<open>rk {C, D, M, P} = 2\<close>
    by linarith
  have i4:"rk {A,B,C,D,M,P} + rk {M,P} \<ge> 3 + rk{M,P}"
    by (simp add: \<open>3 \<le> rk {A, B, C, D, M, P}\<close>)
  from i3 and i4 show "rk {M,P} = 1"
    by (metis (no_types, lifting) \<open>rk {A, B, C, D, M, P} + rk {M, P} \<le> rk {A, B, M, P} + rk {C, D, M, P}\<close>
        \<open>rk {A, B, M, P} = 2\<close> \<open>rk {C, D, M, P} = 2\<close> add_le_cancel_left add_numeral_left antisym
        insert_absorb2 numeral_Bit1 numeral_One numeral_plus_one one_add_one one_le_numeral
        order_trans rk_ax_couple rk_ax_singleton)
qed

(* The following lemma allows to derive that there exists two lines that do not meet, i.e that belong
to two different planes *)
lemma rk_ax_dim_alt: "\<exists>A B C D. \<forall>M. rk {A,B,M} \<noteq> 2 \<or> rk {C,D,M} \<noteq> 2"
proof-
  obtain A B C D where f1:"rk {A,B,C,D} \<ge> 4"
    using rk_ax_dim
    by auto
  have "\<forall>M. rk {A,B,M} \<noteq> 2 \<or> rk {C,D,M} \<noteq> 2"
  proof
    fix M
    have "{A,B,C,D,M} = {A,B,M} \<union> {C,D,M}"
      by auto
    then have "rk {A,B,C,D,M} + rk {M} \<le> rk {A,B,M} + rk {C,D,M}"
      by (smt le_inf_iff matroid_ax_3_alt order_trans subset_insertI)
    then have "rk {A,B,C,D,M} \<le> 3" if "rk {A,B,M} = 2" and "rk {C,D,M} = 2"
      by (smt One_nat_def Suc_leI Suc_le_mono Suc_numeral add_Suc_right add_leD1 add_mono le_antisym
          not_le numeral_3_eq_3 numeral_One numeral_plus_one one_add_one rk_ax_singleton that(1)
          that(2))
    then have "rk {A,B,C,D} \<le> 3" if "rk {A,B,M} = 2" and "rk {C,D,M} = 2"
      by (smt insert_commute matroid_ax_2 order_trans subset_insertI that(1) that(2))
    thus "rk {A, B, M} \<noteq> 2 \<or> rk {C, D, M} \<noteq> 2 "
      using \<open>4 \<le> rk {A, B, C, D}\<close>
      by linarith
  qed
  thus "\<exists>A B C D. \<forall>M. rk {A, B, M} \<noteq> 2 \<or> rk {C, D, M} \<noteq> 2"
    by blast
qed

lemma rk_empty: "rk {} = 0"
proof-
  have "rk {} \<ge> 0"
    by simp
  have "rk {} \<le> 0"
    by (metis card.empty matroid_ax_1b)
  thus "rk {} = 0"
    by blast
qed

lemma matroid_ax_2_alt: "rk X \<le> rk (X \<union> {x}) \<and> rk (X \<union> {x}) \<le> rk X + 1"
proof
  have "X \<subseteq> X \<union> {x}"
    by auto
  thus "rk X \<le> rk (X \<union> {x})"
    by (simp add: matroid_ax_2)
  have "rk {x} \<le> 1"
    by (metis One_nat_def card.empty card_Suc_eq insert_absorb insert_not_empty matroid_ax_1b)
  thus "rk (X \<union> {x}) \<le> rk X + 1"
    by (metis add_leD1 le_antisym matroid_ax_3 rk_ax_singleton)
qed

lemma matroid_ax_3_alt': "rk (X \<union> {y}) = rk (X \<union> {z}) \<longrightarrow> rk (X \<union> {z}) = rk X \<longrightarrow> rk X = rk (X \<union> {y,z})"
proof-
  have i1:"rk X \<le> rk (X \<union> {y,z})"
    using matroid_ax_2
    by blast
  have i2:"rk X \<ge> rk (X \<union> {y,z})" if "rk (X \<union> {y}) = rk (X \<union> {z})" and "rk (X \<union> {z}) = rk X"
  proof-
    have "(X \<union> {y}) \<union> (X \<union> {z}) = X \<union> {y,z}"
      by blast
    then have "rk (X \<union> {y,z}) + rk X \<le> rk X + rk X"
      by (metis \<open>rk (X \<union> {y}) = rk (X \<union> {z})\<close> \<open>rk (X \<union> {z}) = rk X\<close> inf_sup_ord(3) le_inf_iff
          matroid_ax_3_alt)
    thus "rk (X \<union> {y,z}) \<le> rk X"
      by simp
  qed
  thus "rk (X \<union> {y}) = rk (X \<union> {z}) \<longrightarrow> rk (X \<union> {z}) = rk X \<longrightarrow> rk X = rk (X \<union> {y, z})"
    using antisym i1
    by blast
qed

lemma rk_ext:
  assumes "rk X \<le> 3"
  shows "\<exists>P. rk(X \<union> {P}) = rk X + 1"
proof-
  obtain A B C D where "rk {A,B,C,D} \<ge> 4"
    using rk_ax_dim
    by auto
  have f1:"rk (X \<union> {A, B, C, D}) \<ge> 4"
    by (metis Un_upper2 \<open>4 \<le> rk {A, B, C, D}\<close> matroid_ax_2 sup.coboundedI2 sup.orderE)
  have "rk (X \<union> {A, B, C, D}) = rk X" if "rk(X \<union> {A}) = rk(X \<union> {B})" and "rk(X \<union> {B}) = rk(X \<union> {C})"
    and "rk(X \<union> {C}) = rk(X \<union> {D})" and "rk(X \<union> {D}) = rk X"
    using matroid_ax_3_alt' that(1) that(2) that(3) that(4)
    by auto
  then have f2:"rk (X \<union> {A, B, C, D}) \<le> 3" if "rk(X \<union> {A}) = rk(X \<union> {B})" and "rk(X \<union> {B}) = rk(X \<union> {C})"
    and "rk(X \<union> {C}) = rk(X \<union> {D})" and "rk(X \<union> {D}) = rk X"
    using assms that(1) that(2) that(3) that(4)
    by linarith
  from f1 and f2 have "False" if "rk(X \<union> {A}) = rk(X \<union> {B})" and "rk(X \<union> {B}) = rk(X \<union> {C})"
    and "rk(X \<union> {C}) = rk(X \<union> {D})" and "rk(X \<union> {D}) = rk X"
    using that(1) that(2) that(3) that(4)
    by linarith
  then have "rk (X \<union> {A}) = rk X + 1 \<or> rk (X \<union> {B}) = rk X + 1 \<or> rk (X \<union> {C}) = rk X + 1 \<or>
    rk (X \<union> {D}) = rk X + 1"
    by (smt One_nat_def Suc_le_eq Suc_numeral Un_upper2 \<open>4 \<le> rk {A, B, C, D}\<close>
        \<open>\<lbrakk>rk (X \<union> {A}) = rk (X \<union> {B}); rk (X \<union> {B}) = rk (X \<union> {C}); rk (X \<union> {C}) = rk (X \<union> {D}); rk (X \<union> {D}) = rk X\<rbrakk> \<Longrightarrow> rk (X \<union> {A, B, C, D}) = rk X\<close>
        add.right_neutral add_Suc_right assms antisym_conv1 matroid_ax_2 matroid_ax_2_alt
        not_less semiring_norm(2) semiring_norm(8) sup.coboundedI2 sup.orderE)
  thus "\<exists>P . rk (X \<union> {P}) = rk X + 1"
    by blast
qed

lemma rk_singleton : "\<forall>P. rk {P} = 1"
proof
  fix P
  have f1:"rk {P} \<le> 1"
    by (metis One_nat_def card.empty card_Suc_eq insert_absorb insert_not_empty matroid_ax_1b)
  have f2:"rk {P} \<ge> 1"
    using rk_ax_singleton
    by auto
  from f1 and f2 show "rk {P} = 1"
    using antisym
    by blast
qed

lemma rk_singleton_bis :
  assumes "A = B"
  shows "rk {A, B} = 1"
  by (simp add: assms rk_singleton)

lemma rk_couple :
  assumes "A \<noteq> B"
  shows "rk {A, B} = 2"
proof-
  have f1:"rk {A, B} \<le> 2"
    by (metis insert_is_Un matroid_ax_2_alt one_add_one rk_singleton)
  have f2:"rk {A, B} \<ge> 2"
    by (simp add: assms rk_ax_couple)
  from f1 and f2 show "?thesis"
    by (simp add: f1 le_antisym)
qed

lemma rk_triple_le : "rk {A, B, C} \<le> 3"
  by (metis Suc_numeral Un_commute insert_absorb2 insert_is_Un linear matroid_ax_2_alt numeral_2_eq_2
      numeral_3_eq_3 numeral_le_one_iff numeral_plus_one rk_couple rk_singleton semiring_norm(70))

lemma rk_couple_to_singleton :
  assumes "rk {A, B} = 1"
  shows "A = B"
proof-
  have "rk {A, B} = 2" if "A \<noteq> B"
    using rk_couple
    by (simp add: that)
  thus "A = B"
    using assms
    by auto
qed

lemma rk_triple_to_rk_couple :
  assumes "rk {A, B, C} = 3"
  shows "rk {A, B} = 2"
proof-
  have "rk {A, B} \<le> 2"
    using matroid_ax_1b
    by (metis one_le_numeral rk_ax_couple rk_couple rk_singleton_bis)
  have "rk {A, B, C} \<le> 2" if "rk {A, B} = 1"
    using matroid_ax_2_alt[of "{A, B}" C]
    by (simp add: insert_commute that)
  then have "rk {A, B} \<ge> 2"
    using assms rk_ax_couple rk_singleton_bis
    by force
  thus "rk {A, B} = 2"
    by (simp add: \<open>rk {A, B} \<le> 2\<close> le_antisym)
qed

end