(*  Title:      HOL/Multivariate_Analysis/Operator_Norm.thy
    Author:     Amine Chaieb, University of Cambridge
    Author:     Brian Huffman
*)

section {* Operator Norm *}

theory Operator_Norm
imports Complex_Main
begin

text {* This formulation yields zero if @{text 'a} is the trivial vector space. *}

definition onorm :: "('a::real_normed_vector \<Rightarrow> 'b::real_normed_vector) \<Rightarrow> real"
  where "onorm f = (SUP x. norm (f x) / norm x)"

lemma onorm_bound:
  assumes "0 \<le> b" and "\<And>x. norm (f x) \<le> b * norm x"
  shows "onorm f \<le> b"
  unfolding onorm_def
proof (rule cSUP_least)
  fix x
  show "norm (f x) / norm x \<le> b"
    using assms by (cases "x = 0") (simp_all add: pos_divide_le_eq)
qed simp

text {* In non-trivial vector spaces, the first assumption is redundant. *}

lemma onorm_le:
  fixes f :: "'a::{real_normed_vector, perfect_space} \<Rightarrow> 'b::real_normed_vector"
  assumes "\<And>x. norm (f x) \<le> b * norm x"
  shows "onorm f \<le> b"
proof (rule onorm_bound [OF _ assms])
  have "{0::'a} \<noteq> UNIV" by (metis not_open_singleton open_UNIV)
  then obtain a :: 'a where "a \<noteq> 0" by fast
  have "0 \<le> b * norm a"
    by (rule order_trans [OF norm_ge_zero assms])
  with `a \<noteq> 0` show "0 \<le> b"
    by (simp add: zero_le_mult_iff)
qed

lemma le_onorm:
  assumes "bounded_linear f"
  shows "norm (f x) / norm x \<le> onorm f"
proof -
  interpret f: bounded_linear f by fact
  obtain b where "0 \<le> b" and "\<forall>x. norm (f x) \<le> norm x * b"
    using f.nonneg_bounded by auto
  then have "\<forall>x. norm (f x) / norm x \<le> b"
    by (clarify, case_tac "x = 0",
      simp_all add: f.zero pos_divide_le_eq mult.commute)
  then have "bdd_above (range (\<lambda>x. norm (f x) / norm x))"
    unfolding bdd_above_def by fast
  with UNIV_I show ?thesis
    unfolding onorm_def by (rule cSUP_upper)
qed

lemma onorm:
  assumes "bounded_linear f"
  shows "norm (f x) \<le> onorm f * norm x"
proof -
  interpret f: bounded_linear f by fact
  show ?thesis
  proof (cases)
    assume "x = 0"
    then show ?thesis by (simp add: f.zero)
  next
    assume "x \<noteq> 0"
    have "norm (f x) / norm x \<le> onorm f"
      by (rule le_onorm [OF assms])
    then show "norm (f x) \<le> onorm f * norm x"
      by (simp add: pos_divide_le_eq `x \<noteq> 0`)
  qed
qed

lemma onorm_pos_le:
  assumes f: "bounded_linear f"
  shows "0 \<le> onorm f"
  using le_onorm [OF f, where x=0] by simp

lemma onorm_zero: "onorm (\<lambda>x. 0) = 0"
proof (rule order_antisym)
  show "onorm (\<lambda>x. 0) \<le> 0"
    by (simp add: onorm_bound)
  show "0 \<le> onorm (\<lambda>x. 0)"
    using bounded_linear_zero by (rule onorm_pos_le)
qed

lemma onorm_eq_0:
  assumes f: "bounded_linear f"
  shows "onorm f = 0 \<longleftrightarrow> (\<forall>x. f x = 0)"
  using onorm [OF f] by (auto simp: fun_eq_iff [symmetric] onorm_zero)

lemma onorm_pos_lt:
  assumes f: "bounded_linear f"
  shows "0 < onorm f \<longleftrightarrow> \<not> (\<forall>x. f x = 0)"
  by (simp add: less_le onorm_pos_le [OF f] onorm_eq_0 [OF f])

lemma onorm_compose:
  assumes f: "bounded_linear f"
  assumes g: "bounded_linear g"
  shows "onorm (f \<circ> g) \<le> onorm f * onorm g"
proof (rule onorm_bound)
  show "0 \<le> onorm f * onorm g"
    by (intro mult_nonneg_nonneg onorm_pos_le f g)
next
  fix x
  have "norm (f (g x)) \<le> onorm f * norm (g x)"
    by (rule onorm [OF f])
  also have "onorm f * norm (g x) \<le> onorm f * (onorm g * norm x)"
    by (rule mult_left_mono [OF onorm [OF g] onorm_pos_le [OF f]])
  finally show "norm ((f \<circ> g) x) \<le> onorm f * onorm g * norm x"
    by (simp add: mult.assoc)
qed

lemma onorm_scaleR_lemma:
  assumes f: "bounded_linear f"
  shows "onorm (\<lambda>x. r *\<^sub>R f x) \<le> \<bar>r\<bar> * onorm f"
proof (rule onorm_bound)
  show "0 \<le> \<bar>r\<bar> * onorm f"
    by (intro mult_nonneg_nonneg onorm_pos_le abs_ge_zero f)
next
  fix x
  have "\<bar>r\<bar> * norm (f x) \<le> \<bar>r\<bar> * (onorm f * norm x)"
    by (intro mult_left_mono onorm abs_ge_zero f)
  then show "norm (r *\<^sub>R f x) \<le> \<bar>r\<bar> * onorm f * norm x"
    by (simp only: norm_scaleR mult.assoc)
qed

lemma onorm_scaleR:
  assumes f: "bounded_linear f"
  shows "onorm (\<lambda>x. r *\<^sub>R f x) = \<bar>r\<bar> * onorm f"
proof (cases "r = 0")
  assume "r \<noteq> 0"
  show ?thesis
  proof (rule order_antisym)
    show "onorm (\<lambda>x. r *\<^sub>R f x) \<le> \<bar>r\<bar> * onorm f"
      using f by (rule onorm_scaleR_lemma)
  next
    have "bounded_linear (\<lambda>x. r *\<^sub>R f x)"
      using bounded_linear_scaleR_right f by (rule bounded_linear_compose)
    then have "onorm (\<lambda>x. inverse r *\<^sub>R r *\<^sub>R f x) \<le> \<bar>inverse r\<bar> * onorm (\<lambda>x. r *\<^sub>R f x)"
      by (rule onorm_scaleR_lemma)
    with `r \<noteq> 0` show "\<bar>r\<bar> * onorm f \<le> onorm (\<lambda>x. r *\<^sub>R f x)"
      by (simp add: inverse_eq_divide pos_le_divide_eq mult.commute)
  qed
qed (simp add: onorm_zero)

lemma onorm_neg:
  shows "onorm (\<lambda>x. - f x) = onorm f"
  unfolding onorm_def by simp

lemma onorm_triangle:
  assumes f: "bounded_linear f"
  assumes g: "bounded_linear g"
  shows "onorm (\<lambda>x. f x + g x) \<le> onorm f + onorm g"
proof (rule onorm_bound)
  show "0 \<le> onorm f + onorm g"
    by (intro add_nonneg_nonneg onorm_pos_le f g)
next
  fix x
  have "norm (f x + g x) \<le> norm (f x) + norm (g x)"
    by (rule norm_triangle_ineq)
  also have "norm (f x) + norm (g x) \<le> onorm f * norm x + onorm g * norm x"
    by (intro add_mono onorm f g)
  finally show "norm (f x + g x) \<le> (onorm f + onorm g) * norm x"
    by (simp only: distrib_right)
qed

lemma onorm_triangle_le:
  assumes "bounded_linear f"
  assumes "bounded_linear g"
  assumes "onorm f + onorm g \<le> e"
  shows "onorm (\<lambda>x. f x + g x) \<le> e"
  using assms by (rule onorm_triangle [THEN order_trans])

lemma onorm_triangle_lt:
  assumes "bounded_linear f"
  assumes "bounded_linear g"
  assumes "onorm f + onorm g < e"
  shows "onorm (\<lambda>x. f x + g x) < e"
  using assms by (rule onorm_triangle [THEN order_le_less_trans])

end


(*  Title:      HOL/Lattice/Bounds.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Bounds\<close>

theory Bounds imports Orders begin

hide_const (open) inf sup

subsection \<open>Infimum and supremum\<close>

text \<open>
  Given a partial order, we define infimum (greatest lower bound) and
  supremum (least upper bound) wrt.\ \<open>\<sqsubseteq>\<close> for two and for any
  number of elements.
\<close>

definition
  is_inf :: "'a::partial_order \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_inf x y inf = (inf \<sqsubseteq> x \<and> inf \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> inf))"

definition
  is_sup :: "'a::partial_order \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_sup x y sup = (x \<sqsubseteq> sup \<and> y \<sqsubseteq> sup \<and> (\<forall>z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> sup \<sqsubseteq> z))"

definition
  is_Inf :: "'a::partial_order set \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_Inf A inf = ((\<forall>x \<in> A. inf \<sqsubseteq> x) \<and> (\<forall>z. (\<forall>x \<in> A. z \<sqsubseteq> x) \<longrightarrow> z \<sqsubseteq> inf))"

definition
  is_Sup :: "'a::partial_order set \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_Sup A sup = ((\<forall>x \<in> A. x \<sqsubseteq> sup) \<and> (\<forall>z. (\<forall>x \<in> A. x \<sqsubseteq> z) \<longrightarrow> sup \<sqsubseteq> z))"

text \<open>
  These definitions entail the following basic properties of boundary
  elements.
\<close>

lemma is_infI [intro?]: "inf \<sqsubseteq> x \<Longrightarrow> inf \<sqsubseteq> y \<Longrightarrow>
    (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> inf) \<Longrightarrow> is_inf x y inf"
  by (unfold is_inf_def) blast

lemma is_inf_greatest [elim?]:
    "is_inf x y inf \<Longrightarrow> z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> inf"
  by (unfold is_inf_def) blast

lemma is_inf_lower [elim?]:
    "is_inf x y inf \<Longrightarrow> (inf \<sqsubseteq> x \<Longrightarrow> inf \<sqsubseteq> y \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_inf_def) blast

lemma is_supI [intro?]: "x \<sqsubseteq> sup \<Longrightarrow> y \<sqsubseteq> sup \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> sup \<sqsubseteq> z) \<Longrightarrow> is_sup x y sup"
  by (unfold is_sup_def) blast

lemma is_sup_least [elim?]:
    "is_sup x y sup \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> sup \<sqsubseteq> z"
  by (unfold is_sup_def) blast

lemma is_sup_upper [elim?]:
    "is_sup x y sup \<Longrightarrow> (x \<sqsubseteq> sup \<Longrightarrow> y \<sqsubseteq> sup \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_sup_def) blast

lemma is_InfI [intro?]: "(\<And>x. x \<in> A \<Longrightarrow> inf \<sqsubseteq> x) \<Longrightarrow>
    (\<And>z. (\<forall>x \<in> A. z \<sqsubseteq> x) \<Longrightarrow> z \<sqsubseteq> inf) \<Longrightarrow> is_Inf A inf"
  by (unfold is_Inf_def) blast

lemma is_Inf_greatest [elim?]:
    "is_Inf A inf \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x) \<Longrightarrow> z \<sqsubseteq> inf"
  by (unfold is_Inf_def) blast

lemma is_Inf_lower [dest?]:
    "is_Inf A inf \<Longrightarrow> x \<in> A \<Longrightarrow> inf \<sqsubseteq> x"
  by (unfold is_Inf_def) blast

lemma is_SupI [intro?]: "(\<And>x. x \<in> A \<Longrightarrow> x \<sqsubseteq> sup) \<Longrightarrow>
    (\<And>z. (\<forall>x \<in> A. x \<sqsubseteq> z) \<Longrightarrow> sup \<sqsubseteq> z) \<Longrightarrow> is_Sup A sup"
  by (unfold is_Sup_def) blast

lemma is_Sup_least [elim?]:
    "is_Sup A sup \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> x \<sqsubseteq> z) \<Longrightarrow> sup \<sqsubseteq> z"
  by (unfold is_Sup_def) blast

lemma is_Sup_upper [dest?]:
    "is_Sup A sup \<Longrightarrow> x \<in> A \<Longrightarrow> x \<sqsubseteq> sup"
  by (unfold is_Sup_def) blast

subsection \<open>Duality\<close>

text \<open>
  Infimum and supremum are dual to each other.
\<close>

theorem dual_inf [iff?]:
    "is_inf (dual x) (dual y) (dual sup) = is_sup x y sup"
  by (simp add: is_inf_def is_sup_def dual_all [symmetric] dual_leq)

theorem dual_sup [iff?]:
    "is_sup (dual x) (dual y) (dual inf) = is_inf x y inf"
  by (simp add: is_inf_def is_sup_def dual_all [symmetric] dual_leq)

theorem dual_Inf [iff?]:
    "is_Inf (dual ` A) (dual sup) = is_Sup A sup"
  by (simp add: is_Inf_def is_Sup_def dual_all [symmetric] dual_leq)

theorem dual_Sup [iff?]:
    "is_Sup (dual ` A) (dual inf) = is_Inf A inf"
  by (simp add: is_Inf_def is_Sup_def dual_all [symmetric] dual_leq)

subsection \<open>Uniqueness\<close>

text \<open>
  Infima and suprema on partial orders are unique; this is mainly due
  to anti-symmetry of the underlying relation.
\<close>

theorem is_inf_uniq: "is_inf x y inf \<Longrightarrow> is_inf x y inf' \<Longrightarrow> inf = inf'"
proof -
  assume inf: "is_inf x y inf"
  assume inf': "is_inf x y inf'"
  show ?thesis
  proof (rule leq_antisym)
    from inf' show "inf \<sqsubseteq> inf'"
    proof (rule is_inf_greatest)
      from inf show "inf \<sqsubseteq> x" ..
      from inf show "inf \<sqsubseteq> y" ..
    qed
    from inf show "inf' \<sqsubseteq> inf"
    proof (rule is_inf_greatest)
      from inf' show "inf' \<sqsubseteq> x" ..
      from inf' show "inf' \<sqsubseteq> y" ..
    qed
  qed
qed

theorem is_sup_uniq: "is_sup x y sup \<Longrightarrow> is_sup x y sup' \<Longrightarrow> sup = sup'"
proof -
  assume sup: "is_sup x y sup" and sup': "is_sup x y sup'"
  have "dual sup = dual sup'"
  proof (rule is_inf_uniq)
    from sup show "is_inf (dual x) (dual y) (dual sup)" ..
    from sup' show "is_inf (dual x) (dual y) (dual sup')" ..
  qed
  then show "sup = sup'" ..
qed

theorem is_Inf_uniq: "is_Inf A inf \<Longrightarrow> is_Inf A inf' \<Longrightarrow> inf = inf'"
proof -
  assume inf: "is_Inf A inf"
  assume inf': "is_Inf A inf'"
  show ?thesis
  proof (rule leq_antisym)
    from inf' show "inf \<sqsubseteq> inf'"
    proof (rule is_Inf_greatest)
      fix x assume "x \<in> A"
      with inf show "inf \<sqsubseteq> x" ..
    qed
    from inf show "inf' \<sqsubseteq> inf"
    proof (rule is_Inf_greatest)
      fix x assume "x \<in> A"
      with inf' show "inf' \<sqsubseteq> x" ..
    qed
  qed
qed

theorem is_Sup_uniq: "is_Sup A sup \<Longrightarrow> is_Sup A sup' \<Longrightarrow> sup = sup'"
proof -
  assume sup: "is_Sup A sup" and sup': "is_Sup A sup'"
  have "dual sup = dual sup'"
  proof (rule is_Inf_uniq)
    from sup show "is_Inf (dual ` A) (dual sup)" ..
    from sup' show "is_Inf (dual ` A) (dual sup')" ..
  qed
  then show "sup = sup'" ..
qed

subsection \<open>Related elements\<close>

text \<open>
  The binary bound of related elements is either one of the argument.
\<close>

theorem is_inf_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_inf x y x"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> x" ..
    show "x \<sqsubseteq> y" by fact
    fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y" show "z \<sqsubseteq> x" by fact
  qed
qed

theorem is_sup_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_sup x y y"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> y" by fact
    show "y \<sqsubseteq> y" ..
    fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
    show "y \<sqsubseteq> z" by fact
  qed
qed

subsection \<open>General versus binary bounds \label{sec:gen-bin-bounds}\<close>

text \<open>
  General bounds of two-element sets coincide with binary bounds.
\<close>

theorem is_Inf_binary: "is_Inf {x, y} inf = is_inf x y inf"
proof -
  let ?A = "{x, y}"
  show ?thesis
  proof
    assume is_Inf: "is_Inf ?A inf"
    show "is_inf x y inf"
    proof
      have "x \<in> ?A" by simp
      with is_Inf show "inf \<sqsubseteq> x" ..
      have "y \<in> ?A" by simp
      with is_Inf show "inf \<sqsubseteq> y" ..
      fix z assume zx: "z \<sqsubseteq> x" and zy: "z \<sqsubseteq> y"
      from is_Inf show "z \<sqsubseteq> inf"
      proof (rule is_Inf_greatest)
        fix a assume "a \<in> ?A"
        then have "a = x \<or> a = y" by blast
        then show "z \<sqsubseteq> a"
        proof
          assume "a = x"
          with zx show ?thesis by simp
        next
          assume "a = y"
          with zy show ?thesis by simp
        qed
      qed
    qed
  next
    assume is_inf: "is_inf x y inf"
    show "is_Inf {x, y} inf"
    proof
      fix a assume "a \<in> ?A"
      then have "a = x \<or> a = y" by blast
      then show "inf \<sqsubseteq> a"
      proof
        assume "a = x"
        also from is_inf have "inf \<sqsubseteq> x" ..
        finally show ?thesis .
      next
        assume "a = y"
        also from is_inf have "inf \<sqsubseteq> y" ..
        finally show ?thesis .
      qed
    next
      fix z assume z: "\<forall>a \<in> ?A. z \<sqsubseteq> a"
      from is_inf show "z \<sqsubseteq> inf"
      proof (rule is_inf_greatest)
        from z show "z \<sqsubseteq> x" by blast
        from z show "z \<sqsubseteq> y" by blast
      qed
    qed
  qed
qed

theorem is_Sup_binary: "is_Sup {x, y} sup = is_sup x y sup"
proof -
  have "is_Sup {x, y} sup = is_Inf (dual ` {x, y}) (dual sup)"
    by (simp only: dual_Inf)
  also have "dual ` {x, y} = {dual x, dual y}"
    by simp
  also have "is_Inf \<dots> (dual sup) = is_inf (dual x) (dual y) (dual sup)"
    by (rule is_Inf_binary)
  also have "\<dots> = is_sup x y sup"
    by (simp only: dual_inf)
  finally show ?thesis .
qed

subsection \<open>Connecting general bounds \label{sec:connect-bounds}\<close>

text \<open>
  Either kind of general bounds is sufficient to express the other.
  The least upper bound (supremum) is the same as the the greatest
  lower bound of the set of all upper bounds; the dual statements
  holds as well; the dual statement holds as well.
\<close>

theorem Inf_Sup: "is_Inf {b. \<forall>a \<in> A. a \<sqsubseteq> b} sup \<Longrightarrow> is_Sup A sup"
proof -
  let ?B = "{b. \<forall>a \<in> A. a \<sqsubseteq> b}"
  assume is_Inf: "is_Inf ?B sup"
  show "is_Sup A sup"
  proof
    fix x assume x: "x \<in> A"
    from is_Inf show "x \<sqsubseteq> sup"
    proof (rule is_Inf_greatest)
      fix y assume "y \<in> ?B"
      then have "\<forall>a \<in> A. a \<sqsubseteq> y" ..
      from this x show "x \<sqsubseteq> y" ..
    qed
  next
    fix z assume "\<forall>x \<in> A. x \<sqsubseteq> z"
    then have "z \<in> ?B" ..
    with is_Inf show "sup \<sqsubseteq> z" ..
  qed
qed

theorem Sup_Inf: "is_Sup {b. \<forall>a \<in> A. b \<sqsubseteq> a} inf \<Longrightarrow> is_Inf A inf"
proof -
  assume "is_Sup {b. \<forall>a \<in> A. b \<sqsubseteq> a} inf"
  then have "is_Inf (dual ` {b. \<forall>a \<in> A. dual a \<sqsubseteq> dual b}) (dual inf)"
    by (simp only: dual_Inf dual_leq)
  also have "dual ` {b. \<forall>a \<in> A. dual a \<sqsubseteq> dual b} = {b'. \<forall>a' \<in> dual ` A. a' \<sqsubseteq> b'}"
    by (auto iff: dual_ball dual_Collect simp add: image_Collect)  (* FIXME !? *)
  finally have "is_Inf \<dots> (dual inf)" .
  then have "is_Sup (dual ` A) (dual inf)"
    by (rule Inf_Sup)
  then show ?thesis ..
qed

end


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

header{*Computing determinants of matrices using the Gauss Jordan algorithm*}

theory Determinants2
imports
  Gauss_Jordan_PA
begin

subsection{*Some previous properties*}

subsubsection{*Relationships between determinants and elementary row operations*}

lemma det_interchange_rows:
shows "det (interchange_rows A i j) = of_int (if i = j then 1 else -1) * det A"
proof -
  have "(interchange_rows A i j) = (\<chi> a. A $ (Fun.swap i j id) a)" unfolding interchange_rows_def Fun.swap_def by vector
  hence "det(interchange_rows A i j) = det(\<chi> a. A$(Fun.swap i j id) a)" by simp
  also have "... = of_int (sign (Fun.swap i j id)) * det A" by (rule det_permute_rows[of "Fun.swap i j id" A], simp add: permutes_swap_id)
  finally show ?thesis unfolding sign_swap_id .
qed

corollary det_interchange_different_rows:
assumes i_not_j: "i \<noteq> j"
shows "det (interchange_rows A i j) = - det A" unfolding det_interchange_rows using i_not_j by simp

corollary det_interchange_same_rows:
assumes i_eq_j: "i = j"
shows "det (interchange_rows A i j) = det A" unfolding det_interchange_rows using i_eq_j by simp

lemma det_mult_row:
shows "det (mult_row A a k) = k * det A"
proof -
have A_rw: "(\<chi> i. if i = a then A$a else A$i) = A" by vector
have "(mult_row A a k) = (\<chi> i. if i = a then k *s A $ a else A $ i)" unfolding mult_row_def by vector
hence "det(mult_row A a k) = det(\<chi> i. if i = a then k *s A $ a else A $ i)" by simp
also have "... =  k * det(\<chi> i. if i = a then A$a else A$i)" unfolding det_row_mul ..
also have "... = k * det A" unfolding A_rw ..
finally show ?thesis .
qed

(*The name det_row_add is already used in the Determinants.thy file of the standard library*)
lemma det_row_add':
assumes i_not_j: "i \<noteq> j"
shows "det (row_add A i j q) = det A"
proof -
have "(row_add A i j q) = (\<chi> k. if k = i then row i A + q *s row j A else row k A)"
unfolding row_add_def row_def by vector
hence "det(row_add A i j q) = det(\<chi> k. if k = i then row i A + q *s row j A else row k A)" by simp
also have "... = det A" unfolding det_row_operation[OF i_not_j] ..
finally show ?thesis .
qed

subsubsection{*Relationships between determinants and elementary column operations*}

lemma det_interchange_columns:
shows "det (interchange_columns A i j) = of_int (if i = j then 1 else -1) * det A"
proof -
have "(interchange_columns A i j) = (\<chi> a b. A $ a $ (Fun.swap i j id) b)" unfolding interchange_columns_def Fun.swap_def by vector
hence "det(interchange_columns A i j) = det(\<chi> a b. A $ a $ (Fun.swap i j id) b)" by simp
also have "... = of_int (sign (Fun.swap i j id)) * det A" by (rule det_permute_columns[of "Fun.swap i j id" A], simp add: permutes_swap_id)
finally show ?thesis unfolding sign_swap_id .
qed

corollary det_interchange_different_columns:
assumes i_not_j: "i \<noteq> j"
shows "det (interchange_columns A i j) = - det A" unfolding det_interchange_columns using i_not_j by simp

corollary det_interchange_same_columns:
assumes i_eq_j: "i = j"
shows "det (interchange_columns A i j) = det A" unfolding det_interchange_columns using i_eq_j by simp

lemma det_mult_columns:
shows "det (mult_column A a k) = k * det A"
proof -
have "mult_column A a k = transpose (mult_row (transpose A) a k)" unfolding transpose_def mult_row_def mult_column_def by vector
hence "det (mult_column A a k) = det (transpose (mult_row (transpose A) a k))" by simp
also have "... = det (mult_row (transpose A) a k)" unfolding det_transpose ..
also have "... = k * det (transpose A)" unfolding det_mult_row ..
also have "... = k * det A" unfolding det_transpose ..
finally show ?thesis .
qed

lemma det_column_add:
assumes i_not_j: "i \<noteq> j"
shows "det (column_add A i j q) = det A"
proof -
have "(column_add A i j q) = (transpose (row_add (transpose A) i j q))" unfolding transpose_def column_add_def row_add_def by vector
hence "det (column_add A i j q) = det (transpose (row_add (transpose A) i j q))" by simp
also have "... = det (row_add (transpose A) i j q)" unfolding det_transpose ..
also have "... = det A" unfolding det_row_add'[OF i_not_j] det_transpose ..
finally show ?thesis .
qed

subsection{*Proving that the determinant can be computed by means of the Gauss Jordan algorithm*}

subsubsection{*Previous properties*}

lemma det_row_add_iterate_upt_n:
fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
assumes n: "n<nrows A"
shows "det (row_add_iterate A n i j) = det A"
using n
proof (induct n arbitrary: A)
case 0
show ?case unfolding row_add_iterate.simps using det_row_add'[of 0 i A] by auto
next
case (Suc n)
show ?case  unfolding row_add_iterate.simps
proof (auto)
show "det (row_add_iterate A n i j) = det A" using Suc.hyps Suc.prems by simp
assume Suc_n_not_i: "Suc n \<noteq> to_nat i"
have "det (row_add_iterate (row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)) n i j)
= det (row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j))"
proof (rule Suc.hyps, unfold nrows_def)
show " n < CARD('n)" using Suc.prems unfolding nrows_def by auto
qed
also have "... = det A"
  proof (rule det_row_add',rule ccontr, simp)
    assume "from_nat (Suc n) = i"
      hence "to_nat (from_nat (Suc n)::'n) = to_nat i" by simp
      hence "(Suc n) = to_nat i" unfolding to_nat_from_nat_id[OF Suc.prems[unfolded nrows_def]] .
      thus False using Suc_n_not_i by contradiction
    qed
finally show "det (row_add_iterate (row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)) n i j) = det A" .
qed
qed

corollary det_row_add_iterate:
fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
shows "det (row_add_iterate A (nrows A - 1) i j) = det A"
by (metis det_row_add_iterate_upt_n diff_less neq0_conv nrows_not_0 zero_less_one)

lemma det_Gauss_Jordan_in_ij:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
shows "det (Gauss_Jordan_in_ij A i j) = det A' "
proof -
have nrows_eq: "nrows A' = nrows A" unfolding nrows_def by simp
have "row_add_iterate A' (nrows A - 1) i j  =  Gauss_Jordan_in_ij A i j" using row_add_iterate_eq_Gauss_Jordan_in_ij  unfolding A' .
hence "det (Gauss_Jordan_in_ij A i j) = det (row_add_iterate A' (nrows A - 1) i j)" by simp
also have "... = det A'" by (rule det_row_add_iterate[of A', unfolded nrows_eq])
finally show ?thesis .
qed

lemma det_Gauss_Jordan_in_ij_1:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
assumes i: "(LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) = i"
shows "det (Gauss_Jordan_in_ij A i j) = 1/(A$i$j) * det A"
proof -
have "det (Gauss_Jordan_in_ij A i j) = det A' " using det_Gauss_Jordan_in_ij unfolding A' by auto
also have "... = 1/(A$i$j) * det A" unfolding A' det_mult_row unfolding i det_interchange_rows by auto
finally show ?thesis .
qed

lemma det_Gauss_Jordan_in_ij_2:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
assumes i: "(LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) \<noteq> i"
shows "det (Gauss_Jordan_in_ij A i j) = - 1/(A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j) * det A"
proof -
have "det (Gauss_Jordan_in_ij A i j) = det A' " using det_Gauss_Jordan_in_ij unfolding A' by auto
also have "... = - 1/(A$ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $j) * det A" unfolding A' det_mult_row unfolding det_interchange_rows using i by auto
finally show ?thesis .
qed

subsubsection{*Definitions*}

text{*The following definitions allow the computation of the determinant of a matrix using the Gauss-Jordan algorithm. In the first component the determinant of each transformation
is accumulated and the second component contains the matrix transformed into a reduced row echelon form matrix*}

definition Gauss_Jordan_in_ij_det_P :: "'a::{semiring_1, inverse, one, uminus}^'m^'n::{finite, ord}=> 'n=>'m=>('a \<times> ('a^'m^'n::{finite, ord}))"
  where "Gauss_Jordan_in_ij_det_P A i j = (let n = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) in (if i = n then 1/(A $ i $ j) else - 1/(A $ n $ j), Gauss_Jordan_in_ij A i j))"

definition Gauss_Jordan_column_k_det_P where "Gauss_Jordan_column_k_det_P A' k =
(let det_P= fst A'; i = fst (snd A'); A = snd (snd A'); from_nat_i = from_nat i; from_nat_k = from_nat k
 in if (\<forall>m\<ge>from_nat_i. A $ m $ from_nat_k = 0) \<or> i = nrows A then (det_P, i, A)
    else let gauss = Gauss_Jordan_in_ij_det_P A (from_nat_i) (from_nat_k) in (fst gauss * det_P, i + 1, snd gauss))"

definition Gauss_Jordan_upt_k_det_P
  where "Gauss_Jordan_upt_k_det_P A k = (let foldl = foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k] in (fst foldl, snd (snd foldl)))"
definition Gauss_Jordan_det_P
  where "Gauss_Jordan_det_P A = Gauss_Jordan_upt_k_det_P A (ncols A - 1)"

subsubsection{*Proofs*}

text{*This is an equivalent definition created to achieve a more efficient computation.*}
lemma Gauss_Jordan_in_ij_det_P_code[code]:
shows "Gauss_Jordan_in_ij_det_P A i j =
    (let n = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n);
         interchange_A = interchange_rows A i n;
         A' = mult_row interchange_A i (1 / interchange_A $ i $ j) in (if i = n then 1/(A $ i $ j) else - 1/(A $ n $ j), Gauss_Jordan_wrapper i j A' interchange_A))"
         unfolding Gauss_Jordan_in_ij_det_P_def Gauss_Jordan_in_ij_def Gauss_Jordan_wrapper_def Let_def by auto

lemma det_Gauss_Jordan_in_ij_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
shows "(fst (Gauss_Jordan_in_ij_det_P A i j)) * det A  = det (snd (Gauss_Jordan_in_ij_det_P A i j))"
unfolding Gauss_Jordan_in_ij_det_P_def Let_def fst_conv snd_conv
using det_Gauss_Jordan_in_ij_1[of A j i]
using det_Gauss_Jordan_in_ij_2[of A j i] by auto

lemma det_Gauss_Jordan_column_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
assumes det: "det_P * det B = det A"
shows "(fst (Gauss_Jordan_column_k_det_P (det_P,i,A) k)) * det B = det (snd (snd (Gauss_Jordan_column_k_det_P (det_P,i,A) k)))"
proof (unfold Gauss_Jordan_column_k_det_P_def Let_def, auto simp add: assms)
fix m
assume i_not_nrows: "i \<noteq> nrows A"
and i_less_m: "from_nat i \<le> m"
and Amk_not_0: "A $ m $ from_nat k \<noteq> 0"
show  "fst (Gauss_Jordan_in_ij_det_P A (from_nat i) (from_nat k)) * det_P * det B =
        det (snd (Gauss_Jordan_in_ij_det_P A (from_nat i) (from_nat k)))" unfolding mult.assoc det
        unfolding det_Gauss_Jordan_in_ij_det_P ..
qed

lemma det_Gauss_Jordan_upt_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "(fst (Gauss_Jordan_upt_k_det_P A k)) * det A = det (snd (Gauss_Jordan_upt_k_det_P A k))"
proof (induct k)
case 0
show ?case
unfolding Gauss_Jordan_upt_k_det_P_def Let_def unfolding fst_conv snd_conv by (simp add:det_Gauss_Jordan_column_k_det_P)
next
case (Suc k)
have suc_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
have fold_expand: "(foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])
= (fst (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k]), fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])),
  snd (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])))" by simp
show ?case unfolding Gauss_Jordan_upt_k_det_P_def Let_def
unfolding suc_rw foldl_append List.foldl.simps fst_conv snd_conv
by(subst (1 2) fold_expand, rule det_Gauss_Jordan_column_k_det_P, rule Suc.hyps[unfolded Gauss_Jordan_upt_k_det_P_def Let_def fst_conv snd_conv])
qed

lemma det_Gauss_Jordan_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "(fst (Gauss_Jordan_det_P A)) * det A = det (snd (Gauss_Jordan_det_P A))"
using det_Gauss_Jordan_upt_k_det_P unfolding Gauss_Jordan_det_P_def by simp

definition upper_triangular_upt_k where "upper_triangular_upt_k A k = (\<forall>i j. j<i \<and> to_nat j < k \<longrightarrow> A $ i $ j = 0)"
definition upper_triangular where "upper_triangular A = (\<forall>i j. j<i \<longrightarrow> A $ i $ j = 0)"

lemma upper_triangular_upt_imp_upper_triangular:
assumes "upper_triangular_upt_k A (nrows A)"
shows "upper_triangular A"
using assms unfolding upper_triangular_upt_k_def upper_triangular_def nrows_def
using to_nat_less_card[where ?'a='b] by blast

lemma rref_imp_upper_triagular_upt:
fixes A::"'a::{one, zero}^'n::{mod_type}^'n::{mod_type}"
assumes "reduced_row_echelon_form A"
shows "upper_triangular_upt_k A k"
proof (induct k)
case 0
show ?case unfolding upper_triangular_upt_k_def by simp
next
case (Suc k)
show ?case unfolding upper_triangular_upt_k_def proof (clarify)
fix i j::'n
assume j_less_i: "j < i" and j_less_suc_k: "to_nat j < Suc k"
show "A $ i $ j = 0"
  proof (cases "to_nat j < k")
  case True
  thus ?thesis using Suc.hyps unfolding upper_triangular_upt_k_def using j_less_i True by auto
  next
  case False
  hence j_eq_k: "to_nat j = k" using j_less_suc_k by simp
  have rref_suc: "reduced_row_echelon_form_upt_k A (Suc k)" by (metis assms rref_implies_rref_upt)

  show ?thesis
    proof (cases "A $ i $ from_nat k = 0")
      case True
      have "from_nat k = j" by (metis from_nat_to_nat_id j_eq_k)
      thus ?thesis using True by simp
      next
      case False
      have zero_i_k: "is_zero_row_upt_k i k A" unfolding is_zero_row_upt_k_def
      by (metis (hide_lams, mono_tags) Suc.hyps dual_linorder.leD dual_linorder.le_less_linear dual_order.less_imp_le j_eq_k j_less_i le_trans to_nat_mono' upper_triangular_upt_k_def)
      have not_zero_i_suc_k: "\<not> is_zero_row_upt_k i (Suc k) A" unfolding is_zero_row_upt_k_def using False by (metis j_eq_k lessI to_nat_from_nat)
      have Least_eq: "(LEAST n. A $ i $ n \<noteq> 0) = from_nat k"
        proof (rule Least_equality)
           show "A $ i $ from_nat k \<noteq> 0" using False by simp
           show "\<And>y. A $ i $ y \<noteq> 0 \<Longrightarrow> from_nat k \<le> y" by (metis (full_types) is_zero_row_upt_k_def not_leE to_nat_le zero_i_k)
        qed
      have i_not_k: "i \<noteq> from_nat k" by (metis less_irrefl from_nat_to_nat_id j_eq_k j_less_i)
      show ?thesis using rref_upt_condition4_explicit[OF rref_suc not_zero_i_suc_k i_not_k] unfolding Least_eq
      using rref_upt_condition1_explicit[OF rref_suc]
      using Suc.hyps unfolding upper_triangular_upt_k_def
      by (metis (mono_tags) leD dual_linorder.not_leE is_zero_row_upt_k_def is_zero_row_upt_k_suc j_eq_k j_less_i not_zero_i_suc_k to_nat_from_nat to_nat_mono')
qed
qed
qed
qed

lemma rref_imp_upper_triagular:
assumes "reduced_row_echelon_form A"
shows "upper_triangular A"
by (metis assms rref_imp_upper_triagular_upt upper_triangular_upt_imp_upper_triangular)

lemma det_Gauss_Jordan[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "det (Gauss_Jordan A) = setprod (\<lambda>i. (Gauss_Jordan A)$i$i) (UNIV:: 'n set)"
using det_upperdiagonal rref_imp_upper_triagular[OF rref_Gauss_Jordan[of A]] unfolding upper_triangular_def by blast

lemma snd_Gauss_Jordan_in_ij_det_P_is_snd_Gauss_Jordan_in_ij_PA:
shows "snd (Gauss_Jordan_in_ij_det_P A i j) = snd (Gauss_Jordan_in_ij_PA (P,A) i j)"
unfolding Gauss_Jordan_in_ij_det_P_def Gauss_Jordan_in_ij_PA_def
unfolding  Gauss_Jordan_in_ij_def Let_def snd_conv fst_conv ..

lemma snd_Gauss_Jordan_column_k_det_P_is_snd_Gauss_Jordan_column_k_PA:
shows "snd (Gauss_Jordan_column_k_det_P (n,i,A) k) = snd (Gauss_Jordan_column_k_PA (P,i,A) k)"
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def Let_def snd_conv unfolding fst_conv
using snd_Gauss_Jordan_in_ij_det_P_is_snd_Gauss_Jordan_in_ij_PA by auto

lemma det_fst_row_add_iterate_PA:
fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
assumes n: "n<nrows A"
shows "det (fst (row_add_iterate_PA (P,A) n i j)) = det P"
using n
proof (induct n arbitrary: P A)
case 0
show ?case unfolding row_add_iterate_PA.simps using det_row_add'[of 0 i P] by simp
next
case (Suc n)
have n: "n<nrows A" using Suc.prems by simp
show ?case
proof (cases "Suc n = to_nat i")
case True show ?thesis unfolding row_add_iterate_PA.simps if_P[OF True] using Suc.hyps[OF n] .
next
case False
def P'=="row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
def A'=="row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
have n2: "n< nrows A'" using n unfolding nrows_def .
have "det (fst (row_add_iterate_PA (P, A) (Suc n) i j)) = det (fst (row_add_iterate_PA (P', A') n i j))" unfolding row_add_iterate_PA.simps if_not_P[OF False] P'_def A'_def ..
also have "... = det P'" using Suc.hyps[OF n2] .
also have "... = det P" unfolding P'_def
proof (rule det_row_add', rule ccontr, simp)
    assume "from_nat (Suc n) = i"
      hence "to_nat (from_nat (Suc n)::'n) = to_nat i" by simp
      hence "(Suc n) = to_nat i" unfolding to_nat_from_nat_id[OF Suc.prems[unfolded nrows_def]] .
      thus False using False by contradiction
    qed
finally show ?thesis .
qed
qed

lemma det_fst_Gauss_Jordan_in_ij_PA_eq_fst_Gauss_Jordan_in_ij_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_in_ij_det_P A i j) * det P = det (fst (Gauss_Jordan_in_ij_PA (P,A) i j))"
proof -
def P'\<equiv>"mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j)"
def A'\<equiv>"mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j)"
have "det (fst (Gauss_Jordan_in_ij_PA (P,A) i j)) = det (fst (row_add_iterate_PA (P',A') (nrows A - 1) i j))"
unfolding fst_row_add_iterate_PA_eq_fst_Gauss_Jordan_in_ij_PA[symmetric] A'_def P'_def ..
also have "...= det P'" by (rule det_fst_row_add_iterate_PA, simp add: nrows_def)
also have "... = (if i = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) then 1 / A $ i $ j else - 1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j) * det P"
proof (cases "i = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)")
case True show ?thesis
unfolding if_P[OF True] P'_def unfolding True[symmetric] unfolding interchange_same_rows unfolding det_mult_row ..
next
case False
show ?thesis unfolding if_not_P[OF False] P'_def unfolding det_mult_row unfolding det_interchange_different_rows[OF False] by simp
qed
also have "... = fst (Gauss_Jordan_in_ij_det_P A i j) * det P"
unfolding Gauss_Jordan_in_ij_det_P_def by simp
finally show ?thesis ..
qed

lemma det_fst_Gauss_Jordan_column_k_PA_eq_fst_Gauss_Jordan_column_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_column_k_det_P (det P,i,A) k) = det (fst (Gauss_Jordan_column_k_PA (P,i,A) k))"
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def Let_def snd_conv fst_conv
using det_fst_Gauss_Jordan_in_ij_PA_eq_fst_Gauss_Jordan_in_ij_det_P by auto

lemma fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA:
shows "fst (snd (Gauss_Jordan_column_k_det_P (n,i,A) k)) = fst (snd (Gauss_Jordan_column_k_PA (P,i,A) k))"
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def Let_def snd_conv fst_conv
by auto

text{*The way of proving the following lemma is very similar to the demonstration of @{thm "rref_and_index_Gauss_Jordan_upt_k"}.*}

lemma foldl_Gauss_Jordan_column_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows det_fst_Gauss_Jordan_upt_k_PA_eq_fst_Gauss_Jordan_upt_k_det_P: "fst (Gauss_Jordan_upt_k_det_P A k) = det (fst (Gauss_Jordan_upt_k_PA A k))"
and snd_Gauss_Jordan_upt_k_det_P_is_snd_Gauss_Jordan_upt_k_PA: "snd (Gauss_Jordan_upt_k_det_P A k) = snd (Gauss_Jordan_upt_k_PA A k)"
and fst_snd_foldl_Gauss_det_P_PA: "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]))"
proof (induct k)
case 0
show "fst (Gauss_Jordan_upt_k_det_P A 0) = det (fst (Gauss_Jordan_upt_k_PA A 0))"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def
by (simp, metis det_fst_Gauss_Jordan_column_k_PA_eq_fst_Gauss_Jordan_column_k_det_P det_I)
show "snd (Gauss_Jordan_upt_k_det_P A 0) = snd (Gauss_Jordan_upt_k_PA A 0)"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def snd_conv
apply auto using snd_Gauss_Jordan_column_k_det_P_is_snd_Gauss_Jordan_column_k_PA by metis
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc 0])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc 0]))"
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def apply auto
using fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA by metis
next
fix k
assume hyp1: "fst (Gauss_Jordan_upt_k_det_P A k) = det (fst (Gauss_Jordan_upt_k_PA A k))"
and hyp2: "snd (Gauss_Jordan_upt_k_det_P A k) = snd (Gauss_Jordan_upt_k_PA A k)"
and hyp3: "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]))"
have list_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
have det_mat_nn: "det (mat 1::'a^'n::{mod_type}^'n::{mod_type}) = 1" using det_I by simp
def f=="foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k]"
def g=="foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]"
have f_rw: "f = (fst f, fst (snd f), snd(snd f))" by simp
have g_rw: "g = (fst g, fst (snd g), snd(snd g))" by simp
have fst_snd: "fst (snd f) = fst (snd g)" unfolding f_def g_def using hyp3 unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv .
have snd_snd: "snd (snd f) = snd (snd g)" unfolding f_def g_def using hyp2 unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv .
have fst_det: "fst f = det (fst g)" unfolding f_def g_def using hyp1 unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def fst_conv by simp
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k])) \<Longrightarrow>
        fst (Gauss_Jordan_upt_k_det_P A (Suc k)) = det (fst (Gauss_Jordan_upt_k_PA A (Suc k)))"
unfolding Gauss_Jordan_upt_k_det_P_def
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw foldl_append unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
apply (subst g_rw)
unfolding fst_snd snd_snd fst_det
by (rule det_fst_Gauss_Jordan_column_k_PA_eq_fst_Gauss_Jordan_column_k_det_P)
show "snd (Gauss_Jordan_upt_k_det_P A (Suc k)) = snd (Gauss_Jordan_upt_k_PA A (Suc k))"
unfolding Gauss_Jordan_upt_k_det_P_def
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw foldl_append unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
apply (subst g_rw)
unfolding fst_snd snd_snd fst_det
by (metis fst_snd pair_collapse snd_Gauss_Jordan_column_k_det_P_is_snd_Gauss_Jordan_column_k_PA snd_eqD snd_snd)
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc (Suc k)])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc (Suc k)]))"
unfolding Gauss_Jordan_upt_k_det_P_def
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw foldl_append unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
apply (subst g_rw)
unfolding fst_snd snd_snd fst_det by (rule fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA)
qed

lemma snd_Gauss_Jordan_det_P_is_Gauss_Jordan:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "snd (Gauss_Jordan_det_P A) = (Gauss_Jordan A)"
unfolding Gauss_Jordan_det_P_def Gauss_Jordan_def unfolding snd_Gauss_Jordan_upt_k_det_P_is_snd_Gauss_Jordan_upt_k_PA
snd_Gauss_Jordan_upt_k_PA ..

lemma det_snd_Gauss_Jordan_det_P[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "det (snd (Gauss_Jordan_det_P A)) = setprod (\<lambda>i. (snd (Gauss_Jordan_det_P A))$i$i) (UNIV:: 'n set)"
unfolding snd_Gauss_Jordan_det_P_is_Gauss_Jordan det_Gauss_Jordan ..

lemma det_fst_Gauss_Jordan_PA_eq_fst_Gauss_Jordan_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_det_P A) = det (fst (Gauss_Jordan_PA A))"
by (unfold Gauss_Jordan_det_P_def Gauss_Jordan_PA_def, rule det_fst_Gauss_Jordan_upt_k_PA_eq_fst_Gauss_Jordan_upt_k_det_P)

lemma fst_Gauss_Jordan_det_P_not_0:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_det_P A) \<noteq> 0"
unfolding det_fst_Gauss_Jordan_PA_eq_fst_Gauss_Jordan_det_P
by (metis (mono_tags) det_I det_mul invertible_fst_Gauss_Jordan_PA matrix_inv_right mult_zero_left zero_neq_one)

lemma det_code_equation[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "det A = (let A' = Gauss_Jordan_det_P A in setprod (\<lambda>i. (snd (A'))$i$i) (UNIV::'n set)/(fst (A')))"
unfolding Let_def using det_Gauss_Jordan_det_P[of A]
unfolding det_snd_Gauss_Jordan_det_P
by (metis comm_semiring_1_class.normalizing_semiring_rules(7) fst_Gauss_Jordan_det_P_not_0 nonzero_eq_divide_eq)

end


(*  Title:      HOL/Number_Theory/Cong.thy
    Author:     Christophe Tabacznyj
    Author:     Lawrence C. Paulson
    Author:     Amine Chaieb
    Author:     Thomas M. Rasmussen
    Author:     Jeremy Avigad

Defines congruence (notation: [x = y] (mod z)) for natural numbers and
integers.

This file combines and revises a number of prior developments.

The original theories "GCD" and "Primes" were by Christophe Tabacznyj
and Lawrence C. Paulson, based on @{cite davenport92}. They introduced
gcd, lcm, and prime for the natural numbers.

The original theory "IntPrimes" was by Thomas M. Rasmussen, and
extended gcd, lcm, primes to the integers. Amine Chaieb provided
another extension of the notions to the integers, and added a number
of results to "Primes" and "GCD".

The original theory, "IntPrimes", by Thomas M. Rasmussen, defined and
developed the congruence relations on the integers. The notion was
extended to the natural numbers by Chaieb. Jeremy Avigad combined
these, revised and tidied them, made the development uniform for the
natural numbers and the integers, and added a number of new theorems.
*)

section \<open>Congruence\<close>

theory Cong
  imports "HOL-Computational_Algebra.Primes"
begin

subsection \<open>Generic congruences\<close>

context unique_euclidean_semiring
begin

definition cong :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  (\<open>(1[_ = _] '(' mod _'))\<close>)
  where "cong b c a \<longleftrightarrow> b mod a = c mod a"

abbreviation notcong :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  (\<open>(1[_ \<noteq> _] '(' mod _'))\<close>)
  where "notcong b c a \<equiv> \<not> cong b c a"

lemma cong_refl [simp]:
  "[b = b] (mod a)"
  by (simp add: cong_def)

lemma cong_sym:
  "[b = c] (mod a) \<Longrightarrow> [c = b] (mod a)"
  by (simp add: cong_def)

lemma cong_sym_eq:
  "[b = c] (mod a) \<longleftrightarrow> [c = b] (mod a)"
  by (auto simp add: cong_def)

lemma cong_trans [trans]:
  "[b = c] (mod a) \<Longrightarrow> [c = d] (mod a) \<Longrightarrow> [b = d] (mod a)"
  by (simp add: cong_def)

lemma cong_mult_self_right:
  "[b * a = 0] (mod a)"
  by (simp add: cong_def)

lemma cong_mult_self_left:
  "[a * b = 0] (mod a)"
  by (simp add: cong_def)

lemma cong_mod_left [simp]:
  "[b mod a = c] (mod a) \<longleftrightarrow> [b = c] (mod a)"
  by (simp add: cong_def)

lemma cong_mod_right [simp]:
  "[b = c mod a] (mod a) \<longleftrightarrow> [b = c] (mod a)"
  by (simp add: cong_def)

lemma cong_0 [simp, presburger]:
  "[b = c] (mod 0) \<longleftrightarrow> b = c"
  by (simp add: cong_def)

lemma cong_1 [simp, presburger]:
  "[b = c] (mod 1)"
  by (simp add: cong_def)

lemma cong_dvd_iff:
  "a dvd b \<longleftrightarrow> a dvd c" if "[b = c] (mod a)"
  using that by (auto simp: cong_def dvd_eq_mod_eq_0)

lemma cong_0_iff: "[b = 0] (mod a) \<longleftrightarrow> a dvd b"
  by (simp add: cong_def dvd_eq_mod_eq_0)

lemma cong_add:
  "[b = c] (mod a) \<Longrightarrow> [d = e] (mod a) \<Longrightarrow> [b + d = c + e] (mod a)"
  by (auto simp add: cong_def intro: mod_add_cong)

lemma cong_mult:
  "[b = c] (mod a) \<Longrightarrow> [d = e] (mod a) \<Longrightarrow> [b * d = c * e] (mod a)"
  by (auto simp add: cong_def intro: mod_mult_cong)

lemma cong_scalar_right:
  "[b = c] (mod a) \<Longrightarrow> [b * d = c * d] (mod a)"
  by (simp add: cong_mult)

lemma cong_scalar_left:
  "[b = c] (mod a) \<Longrightarrow> [d * b = d * c] (mod a)"
  by (simp add: cong_mult)

lemma cong_pow:
  "[b = c] (mod a) \<Longrightarrow> [b ^ n = c ^ n] (mod a)"
  by (simp add: cong_def power_mod [symmetric, of b n a] power_mod [symmetric, of c n a])

lemma cong_sum:
  "[sum f A = sum g A] (mod a)" if "\<And>x. x \<in> A \<Longrightarrow> [f x = g x] (mod a)"
  using that by (induct A rule: infinite_finite_induct) (auto intro: cong_add)

lemma cong_prod:
  "[prod f A = prod g A] (mod a)" if "(\<And>x. x \<in> A \<Longrightarrow> [f x = g x] (mod a))"
  using that by (induct A rule: infinite_finite_induct) (auto intro: cong_mult)

lemma mod_mult_cong_right:
  "[c mod (a * b) = d] (mod a) \<longleftrightarrow> [c = d] (mod a)"
  by (simp add: cong_def mod_mod_cancel mod_add_left_eq)

lemma mod_mult_cong_left:
  "[c mod (b * a) = d] (mod a) \<longleftrightarrow> [c = d] (mod a)"
  using mod_mult_cong_right [of c a b d] by (simp add: ac_simps)

end

context unique_euclidean_ring
begin

lemma cong_diff:
  "[b = c] (mod a) \<Longrightarrow> [d = e] (mod a) \<Longrightarrow> [b - d = c - e] (mod a)"
  by (auto simp add: cong_def intro: mod_diff_cong)

lemma cong_diff_iff_cong_0:
  "[b - c = 0] (mod a) \<longleftrightarrow> [b = c] (mod a)" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?P
  then have "[b - c + c = 0 + c] (mod a)"
    by (rule cong_add) simp
  then show ?Q
    by simp
next
  assume ?Q
  with cong_diff [of b c a c c] show ?P
    by simp
qed

lemma cong_minus_minus_iff:
  "[- b = - c] (mod a) \<longleftrightarrow> [b = c] (mod a)"
  using cong_diff_iff_cong_0 [of b c a] cong_diff_iff_cong_0 [of "- b" "- c" a]
  by (simp add: cong_0_iff dvd_diff_commute)

lemma cong_modulus_minus_iff [iff]:
  "[b = c] (mod - a) \<longleftrightarrow> [b = c] (mod a)"
  using cong_diff_iff_cong_0 [of b c a] cong_diff_iff_cong_0 [of b c " -a"]
  by (simp add: cong_0_iff)

lemma cong_iff_dvd_diff:
  "[a = b] (mod m) \<longleftrightarrow> m dvd (a - b)"
  by (simp add: cong_0_iff [symmetric] cong_diff_iff_cong_0)

lemma cong_iff_lin:
  "[a = b] (mod m) \<longleftrightarrow> (\<exists>k. b = a + m * k)" (is "?P \<longleftrightarrow> ?Q")
proof -
  have "?P \<longleftrightarrow> m dvd b - a"
    by (simp add: cong_iff_dvd_diff dvd_diff_commute)
  also have "\<dots> \<longleftrightarrow> ?Q"
    by (auto simp add: algebra_simps elim!: dvdE)
  finally show ?thesis
    by simp
qed

lemma cong_add_lcancel:
  "[a + x = a + y] (mod n) \<longleftrightarrow> [x = y] (mod n)"
  by (simp add: cong_iff_lin algebra_simps)

lemma cong_add_rcancel:
  "[x + a = y + a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
  by (simp add: cong_iff_lin algebra_simps)

lemma cong_add_lcancel_0:
  "[a + x = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
  using cong_add_lcancel [of a x 0 n] by simp

lemma cong_add_rcancel_0:
  "[x + a = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
  using cong_add_rcancel [of x a 0 n] by simp

lemma cong_dvd_modulus:
  "[x = y] (mod n)" if "[x = y] (mod m)" and "n dvd m"
  using that by (auto intro: dvd_trans simp add: cong_iff_dvd_diff)

lemma cong_modulus_mult:
  "[x = y] (mod m)" if "[x = y] (mod m * n)"
  using that by (simp add: cong_iff_dvd_diff) (rule dvd_mult_left)

end

lemma cong_abs [simp]:
  "[x = y] (mod \<bar>m\<bar>) \<longleftrightarrow> [x = y] (mod m)"
  for x y :: "'a :: {unique_euclidean_ring, linordered_idom}"
  by (simp add: cong_iff_dvd_diff)

lemma cong_square:
  "prime p \<Longrightarrow> 0 < a \<Longrightarrow> [a * a = 1] (mod p) \<Longrightarrow> [a = 1] (mod p) \<or> [a = - 1] (mod p)"
  for a p :: "'a :: {normalization_semidom, linordered_idom, unique_euclidean_ring}"
  by (auto simp add: cong_iff_dvd_diff square_diff_one_factored dest: prime_dvd_multD)

lemma cong_mult_rcancel:
  "[a * k = b * k] (mod m) \<longleftrightarrow> [a = b] (mod m)"
  if "coprime k m" for a k m :: "'a::{unique_euclidean_ring, ring_gcd}"
  using that by (auto simp add: cong_iff_dvd_diff left_diff_distrib [symmetric] ac_simps coprime_dvd_mult_right_iff)

lemma cong_mult_lcancel:
  "[k * a = k * b] (mod m) = [a = b] (mod m)"
  if "coprime k m" for a k m :: "'a::{unique_euclidean_ring, ring_gcd}"
  using that cong_mult_rcancel [of k m a b] by (simp add: ac_simps)

lemma coprime_cong_mult:
  "[a = b] (mod m) \<Longrightarrow> [a = b] (mod n) \<Longrightarrow> coprime m n \<Longrightarrow> [a = b] (mod m * n)"
  for a b :: "'a :: {unique_euclidean_ring, semiring_gcd}"
  by (simp add: cong_iff_dvd_diff divides_mult)

lemma cong_gcd_eq:
  "gcd a m = gcd b m" if "[a = b] (mod m)"
  for a b :: "'a :: {unique_euclidean_semiring, euclidean_semiring_gcd}"
proof (cases "m = 0")
  case True
  with that show ?thesis
    by simp
next
  case False
  moreover have "gcd (a mod m) m = gcd (b mod m) m"
    using that by (simp add: cong_def)
  ultimately show ?thesis
    by simp
qed

lemma cong_imp_coprime:
  "[a = b] (mod m) \<Longrightarrow> coprime a m \<Longrightarrow> coprime b m"
  for a b :: "'a :: {unique_euclidean_semiring, euclidean_semiring_gcd}"
  by (auto simp add: coprime_iff_gcd_eq_1 dest: cong_gcd_eq)

lemma cong_cong_prod_coprime:
  "[x = y] (mod (\<Prod>i\<in>A. m i))" if
    "(\<forall>i\<in>A. [x = y] (mod m i))"
    "(\<forall>i\<in>A. (\<forall>j\<in>A. i \<noteq> j \<longrightarrow> coprime (m i) (m j)))"
  for x y :: "'a :: {unique_euclidean_ring, semiring_gcd}"
  using that by (induct A rule: infinite_finite_induct)
    (auto intro!: coprime_cong_mult prod_coprime_right)

subsection \<open>Congruences on \<^typ>\<open>nat\<close> and \<^typ>\<open>int\<close>\<close>

lemma cong_int_iff:
  "[int m = int q] (mod int n) \<longleftrightarrow> [m = q] (mod n)"
  by (simp add: cong_def of_nat_mod [symmetric])

lemma cong_Suc_0 [simp, presburger]:
  "[m = n] (mod Suc 0)"
  using cong_1 [of m n] by simp

lemma cong_diff_nat:
  "[a - c = b - d] (mod m)" if "[a = b] (mod m)" "[c = d] (mod m)"
    and "a \<ge> c" "b \<ge> d" for a b c d m :: nat
proof -
  have "[c + (a - c) = d + (b - d)] (mod m)"
    using that by simp
  with \<open>[c = d] (mod m)\<close> have "[c + (a - c) = c + (b - d)] (mod m)"
    using mod_add_cong by (auto simp add: cong_def) fastforce
  then show ?thesis
    by (simp add: cong_def nat_mod_eq_iff)
qed

lemma cong_diff_iff_cong_0_nat:
  "[a - b = 0] (mod m) \<longleftrightarrow> [a = b] (mod m)" if "a \<ge> b" for a b :: nat
  using that by (simp add: cong_0_iff) (simp add: cong_def mod_eq_dvd_iff_nat)

lemma cong_diff_iff_cong_0_nat':
  "[nat \<bar>int a - int b\<bar> = 0] (mod m) \<longleftrightarrow> [a = b] (mod m)"
proof (cases "b \<le> a")
  case True
  then show ?thesis
    by (simp add: nat_diff_distrib' cong_diff_iff_cong_0_nat [of b a m])
next
  case False
  then have "a \<le> b"
    by simp
  then show ?thesis
    by (simp add: nat_diff_distrib' cong_diff_iff_cong_0_nat [of a b m])
      (auto simp add: cong_def)
qed

lemma cong_altdef_nat:
  "a \<ge> b \<Longrightarrow> [a = b] (mod m) \<longleftrightarrow> m dvd (a - b)"
  for a b :: nat
  by (simp add: cong_0_iff [symmetric] cong_diff_iff_cong_0_nat)

lemma cong_altdef_nat':
  "[a = b] (mod m) \<longleftrightarrow> m dvd nat \<bar>int a - int b\<bar>"
  using cong_diff_iff_cong_0_nat' [of a b m]
  by (simp only: cong_0_iff [symmetric])

lemma cong_mult_rcancel_nat:
  "[a * k = b * k] (mod m) \<longleftrightarrow> [a = b] (mod m)"
  if "coprime k m" for a k m :: nat
proof -
  have "[a * k = b * k] (mod m) \<longleftrightarrow> m dvd nat \<bar>int (a * k) - int (b * k)\<bar>"
    by (simp add: cong_altdef_nat')
  also have "\<dots> \<longleftrightarrow> m dvd nat \<bar>(int a - int b) * int k\<bar>"
    by (simp add: algebra_simps)
  also have "\<dots> \<longleftrightarrow> m dvd nat \<bar>int a - int b\<bar> * k"
    by (simp add: abs_mult nat_times_as_int)
  also have "\<dots> \<longleftrightarrow> m dvd nat \<bar>int a - int b\<bar>"
    by (rule coprime_dvd_mult_left_iff) (use \<open>coprime k m\<close> in \<open>simp add: ac_simps\<close>)
  also have "\<dots> \<longleftrightarrow> [a = b] (mod m)"
    by (simp add: cong_altdef_nat')
  finally show ?thesis .
qed

lemma cong_mult_lcancel_nat:
  "[k * a = k * b] (mod m) = [a = b] (mod m)"
  if "coprime k m" for a k m :: nat
  using that by (simp add: cong_mult_rcancel_nat ac_simps)

lemma coprime_cong_mult_nat:
  "[a = b] (mod m) \<Longrightarrow> [a = b] (mod n) \<Longrightarrow> coprime m n \<Longrightarrow> [a = b] (mod m * n)"
  for a b :: nat
  by (simp add: cong_altdef_nat' divides_mult)

lemma cong_less_imp_eq_nat: "0 \<le> a \<Longrightarrow> a < m \<Longrightarrow> 0 \<le> b \<Longrightarrow> b < m \<Longrightarrow> [a = b] (mod m) \<Longrightarrow> a = b"
  for a b :: nat
  by (auto simp add: cong_def)

lemma cong_less_imp_eq_int: "0 \<le> a \<Longrightarrow> a < m \<Longrightarrow> 0 \<le> b \<Longrightarrow> b < m \<Longrightarrow> [a = b] (mod m) \<Longrightarrow> a = b"
  for a b :: int
  by (auto simp add: cong_def)

lemma cong_less_unique_nat: "0 < m \<Longrightarrow> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
  for a m :: nat
  by (auto simp: cong_def) (metis mod_mod_trivial mod_less_divisor)

lemma cong_less_unique_int: "0 < m \<Longrightarrow> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
  for a m :: int
  by (auto simp add: cong_def) (metis mod_mod_trivial pos_mod_bound pos_mod_sign)

lemma cong_iff_lin_nat: "[a = b] (mod m) \<longleftrightarrow> (\<exists>k1 k2. b + k1 * m = a + k2 * m)"
  for a b :: nat
  apply (auto simp add: cong_def nat_mod_eq_iff)
   apply (metis mult.commute)
  apply (metis mult.commute)
  done

lemma cong_cong_mod_nat: "[a = b] (mod m) \<longleftrightarrow> [a mod m = b mod m] (mod m)"
  for a b :: nat
  by simp

lemma cong_cong_mod_int: "[a = b] (mod m) \<longleftrightarrow> [a mod m = b mod m] (mod m)"
  for a b :: int
  by simp

lemma cong_add_lcancel_nat: "[a + x = a + y] (mod n) \<longleftrightarrow> [x = y] (mod n)"
  for a x y :: nat
  by (simp add: cong_iff_lin_nat)

lemma cong_add_rcancel_nat: "[x + a = y + a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
  for a x y :: nat
  by (simp add: cong_iff_lin_nat)

lemma cong_add_lcancel_0_nat: "[a + x = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
  for a x :: nat
  using cong_add_lcancel_nat [of a x 0 n] by simp

lemma cong_add_rcancel_0_nat: "[x + a = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
  for a x :: nat
  using cong_add_rcancel_nat [of x a 0 n] by simp

lemma cong_dvd_modulus_nat: "[x = y] (mod m) \<Longrightarrow> n dvd m \<Longrightarrow> [x = y] (mod n)"
  for x y :: nat
  by (auto simp add: cong_altdef_nat')

lemma cong_to_1_nat:
  fixes a :: nat
  assumes "[a = 1] (mod n)"
  shows "n dvd (a - 1)"
proof (cases "a = 0")
  case True
  then show ?thesis by force
next
  case False
  with assms show ?thesis by (metis cong_altdef_nat leI less_one)
qed

lemma cong_0_1_nat': "[0 = Suc 0] (mod n) \<longleftrightarrow> n = Suc 0"
  by (auto simp: cong_def)

lemma cong_0_1_nat: "[0 = 1] (mod n) \<longleftrightarrow> n = 1"
  for n :: nat
  by (auto simp: cong_def)

lemma cong_0_1_int: "[0 = 1] (mod n) \<longleftrightarrow> n = 1 \<or> n = - 1"
  for n :: int
  by (auto simp: cong_def zmult_eq_1_iff)

lemma cong_to_1'_nat: "[a = 1] (mod n) \<longleftrightarrow> a = 0 \<and> n = 1 \<or> (\<exists>m. a = 1 + m * n)"
  for a :: nat
  by (metis add.right_neutral cong_0_1_nat cong_iff_lin_nat cong_to_1_nat
      dvd_div_mult_self leI le_add_diff_inverse less_one mult_eq_if)

lemma cong_le_nat: "y \<le> x \<Longrightarrow> [x = y] (mod n) \<longleftrightarrow> (\<exists>q. x = q * n + y)"
  for x y :: nat
  by (auto simp add: cong_altdef_nat le_imp_diff_is_add)

lemma cong_solve_nat:
  fixes a :: nat
  shows "\<exists>x. [a * x = gcd a n] (mod n)"
proof (cases "a = 0 \<or> n = 0")
  case True
  then show ?thesis
    by (force simp add: cong_0_iff cong_sym)
next
  case False
  then show ?thesis
    using bezout_nat [of a n]
    by auto (metis cong_add_rcancel_0_nat cong_mult_self_left)
qed

lemma cong_solve_int:
  fixes a :: int
  shows "\<exists>x. [a * x = gcd a n] (mod n)"
    by (metis bezout_int cong_iff_lin mult.commute)

lemma cong_solve_dvd_nat:
  fixes a :: nat
  assumes "gcd a n dvd d"
  shows "\<exists>x. [a * x = d] (mod n)"
proof -
  from cong_solve_nat [of a] obtain x where "[a * x = gcd a n](mod n)"
    by auto
  then have "[(d div gcd a n) * (a * x) = (d div gcd a n) * gcd a n] (mod n)"
    using cong_scalar_left by blast
  also from assms have "(d div gcd a n) * gcd a n = d"
    by (rule dvd_div_mult_self)
  also have "(d div gcd a n) * (a * x) = a * (d div gcd a n * x)"
    by auto
  finally show ?thesis
    by auto
qed

lemma cong_solve_dvd_int:
  fixes a::int
  assumes b: "gcd a n dvd d"
  shows "\<exists>x. [a * x = d] (mod n)"
proof -
  from cong_solve_int [of a] obtain x where "[a * x = gcd a n](mod n)"
    by auto
  then have "[(d div gcd a n) * (a * x) = (d div gcd a n) * gcd a n] (mod n)"
    using cong_scalar_left by blast
  also from b have "(d div gcd a n) * gcd a n = d"
    by (rule dvd_div_mult_self)
  also have "(d div gcd a n) * (a * x) = a * (d div gcd a n * x)"
    by auto
  finally show ?thesis
    by auto
qed

lemma cong_solve_coprime_nat:
  "\<exists>x. [a * x = Suc 0] (mod n)" if "coprime a n"
  using that cong_solve_nat [of a n] by auto

lemma cong_solve_coprime_int:
  "\<exists>x. [a * x = 1] (mod n)" if "coprime a n" for a n x :: int
  using that cong_solve_int [of a n] by (auto simp add: zabs_def split: if_splits)

lemma coprime_iff_invertible_nat:
  "coprime a m \<longleftrightarrow> (\<exists>x. [a * x = Suc 0] (mod m))" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?P then show ?Q
    by (auto dest!: cong_solve_coprime_nat)
next
  assume ?Q
  then obtain b where "[a * b = Suc 0] (mod m)"
    by blast
  with coprime_mod_left_iff [of m "a * b"] show ?P
    by (cases "m = 0 \<or> m = 1")
      (unfold cong_def, auto simp add: cong_def)
qed

lemma coprime_iff_invertible_int:
  "coprime a m \<longleftrightarrow> (\<exists>x. [a * x = 1] (mod m))" (is "?P \<longleftrightarrow> ?Q") for m :: int
proof
  assume ?P then show ?Q
    by (auto dest: cong_solve_coprime_int)
next
  assume ?Q
  then obtain b where "[a * b = 1] (mod m)"
    by blast
  with coprime_mod_left_iff [of m "a * b"] show ?P
    by (cases "m = 0 \<or> m = 1")
      (unfold cong_def, auto simp add: zmult_eq_1_iff)
qed

lemma coprime_iff_invertible'_nat:
  assumes "m > 0"
  shows "coprime a m \<longleftrightarrow> (\<exists>x. 0 \<le> x \<and> x < m \<and> [a * x = Suc 0] (mod m))"
proof -
  have "\<And>b. \<lbrakk>0 < m; [a * b = Suc 0] (mod m)\<rbrakk> \<Longrightarrow> \<exists>b'<m. [a * b' = Suc 0] (mod m)"
    by (metis cong_def mod_less_divisor [OF assms] mod_mult_right_eq)
  then show ?thesis
    using assms coprime_iff_invertible_nat by auto
qed

lemma coprime_iff_invertible'_int:
  fixes m :: int
  assumes "m > 0"
  shows "coprime a m \<longleftrightarrow> (\<exists>x. 0 \<le> x \<and> x < m \<and> [a * x = 1] (mod m))"
  using assms by (simp add: coprime_iff_invertible_int)
    (metis assms cong_mod_left mod_mult_right_eq pos_mod_bound pos_mod_sign)

lemma cong_cong_lcm_nat: "[x = y] (mod a) \<Longrightarrow> [x = y] (mod b) \<Longrightarrow> [x = y] (mod lcm a b)"
  for x y :: nat
  by (meson cong_altdef_nat' lcm_least)

lemma cong_cong_lcm_int: "[x = y] (mod a) \<Longrightarrow> [x = y] (mod b) \<Longrightarrow> [x = y] (mod lcm a b)"
  for x y :: int
  by (auto simp add: cong_iff_dvd_diff lcm_least)

lemma cong_cong_prod_coprime_nat:
  "[x = y] (mod (\<Prod>i\<in>A. m i))" if
    "(\<forall>i\<in>A. [x = y] (mod m i))"
    "(\<forall>i\<in>A. (\<forall>j\<in>A. i \<noteq> j \<longrightarrow> coprime (m i) (m j)))"
  for x y :: nat
  using that by (induct A rule: infinite_finite_induct)
    (auto intro!: coprime_cong_mult_nat prod_coprime_right)

lemma binary_chinese_remainder_nat:
  fixes m1 m2 :: nat
  assumes a: "coprime m1 m2"
  shows "\<exists>x. [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
proof -
  have "\<exists>b1 b2. [b1 = 1] (mod m1) \<and> [b1 = 0] (mod m2) \<and> [b2 = 0] (mod m1) \<and> [b2 = 1] (mod m2)"
  proof -
    from cong_solve_coprime_nat [OF a] obtain x1 where 1: "[m1 * x1 = 1] (mod m2)"
      by auto
    from a have b: "coprime m2 m1"
      by (simp add: ac_simps)
    from cong_solve_coprime_nat [OF b] obtain x2 where 2: "[m2 * x2 = 1] (mod m1)"
      by auto
    have "[m1 * x1 = 0] (mod m1)"
      by (simp add: cong_mult_self_left)
    moreover have "[m2 * x2 = 0] (mod m2)"
      by (simp add: cong_mult_self_left)
    ultimately show ?thesis
      using 1 2 by blast
  qed
  then obtain b1 b2
    where "[b1 = 1] (mod m1)" and "[b1 = 0] (mod m2)"
      and "[b2 = 0] (mod m1)" and "[b2 = 1] (mod m2)"
    by blast
  let ?x = "u1 * b1 + u2 * b2"
  have "[?x = u1 * 1 + u2 * 0] (mod m1)"
    using \<open>[b1 = 1] (mod m1)\<close> \<open>[b2 = 0] (mod m1)\<close> cong_add cong_scalar_left by blast
  then have "[?x = u1] (mod m1)" by simp
  have "[?x = u1 * 0 + u2 * 1] (mod m2)"
    using \<open>[b1 = 0] (mod m2)\<close> \<open>[b2 = 1] (mod m2)\<close> cong_add cong_scalar_left by blast
  then have "[?x = u2] (mod m2)"
    by simp
  with \<open>[?x = u1] (mod m1)\<close> show ?thesis
    by blast
qed

lemma binary_chinese_remainder_int:
  fixes m1 m2 :: int
  assumes a: "coprime m1 m2"
  shows "\<exists>x. [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
proof -
  have "\<exists>b1 b2. [b1 = 1] (mod m1) \<and> [b1 = 0] (mod m2) \<and> [b2 = 0] (mod m1) \<and> [b2 = 1] (mod m2)"
  proof -
    from cong_solve_coprime_int [OF a] obtain x1 where 1: "[m1 * x1 = 1] (mod m2)"
      by auto
    from a have b: "coprime m2 m1"
      by (simp add: ac_simps)
    from cong_solve_coprime_int [OF b] obtain x2 where 2: "[m2 * x2 = 1] (mod m1)"
      by auto
    have "[m1 * x1 = 0] (mod m1)"
     by (simp add: cong_mult_self_left)
    moreover have "[m2 * x2 = 0] (mod m2)"
      by (simp add: cong_mult_self_left)
    ultimately show ?thesis
      using 1 2 by blast
  qed
  then obtain b1 b2
    where "[b1 = 1] (mod m1)" and "[b1 = 0] (mod m2)"
      and "[b2 = 0] (mod m1)" and "[b2 = 1] (mod m2)"
    by blast
  let ?x = "u1 * b1 + u2 * b2"
  have "[?x = u1 * 1 + u2 * 0] (mod m1)"
    using \<open>[b1 = 1] (mod m1)\<close> \<open>[b2 = 0] (mod m1)\<close> cong_add cong_scalar_left by blast
  then have "[?x = u1] (mod m1)" by simp
  have "[?x = u1 * 0 + u2 * 1] (mod m2)"
    using \<open>[b1 = 0] (mod m2)\<close> \<open>[b2 = 1] (mod m2)\<close> cong_add cong_scalar_left by blast
  then have "[?x = u2] (mod m2)" by simp
  with \<open>[?x = u1] (mod m1)\<close> show ?thesis
    by blast
qed

lemma cong_modulus_mult_nat: "[x = y] (mod m * n) \<Longrightarrow> [x = y] (mod m)"
  for x y :: nat
  by (metis cong_def mod_mult_cong_right)

lemma cong_less_modulus_unique_nat: "[x = y] (mod m) \<Longrightarrow> x < m \<Longrightarrow> y < m \<Longrightarrow> x = y"
  for x y :: nat
  by (simp add: cong_def)

lemma binary_chinese_remainder_unique_nat:
  fixes m1 m2 :: nat
  assumes a: "coprime m1 m2"
    and nz: "m1 \<noteq> 0" "m2 \<noteq> 0"
  shows "\<exists>!x. x < m1 * m2 \<and> [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
proof -
  obtain y where y1: "[y = u1] (mod m1)" and y2: "[y = u2] (mod m2)"
    using binary_chinese_remainder_nat [OF a] by blast
  let ?x = "y mod (m1 * m2)"
  from nz have less: "?x < m1 * m2"
    by auto
  have 1: "[?x = u1] (mod m1)"
    using y1 mod_mult_cong_right by blast
  have 2: "[?x = u2] (mod m2)"
    using y2 mod_mult_cong_left by blast
  have "z = ?x" if "z < m1 * m2" "[z = u1] (mod m1)"  "[z = u2] (mod m2)" for z
  proof -
    have "[?x = z] (mod m1)"
      by (metis "1" cong_def that(2))
    moreover have "[?x = z] (mod m2)"
      by (metis "2" cong_def that(3))
    ultimately have "[?x = z] (mod m1 * m2)"
      using a by (auto intro: coprime_cong_mult_nat simp add: mod_mult_cong_left mod_mult_cong_right)
    with \<open>z < m1 * m2\<close> \<open>?x < m1 * m2\<close> show "z = ?x"
      by (auto simp add: cong_def)
  qed
  with less 1 2 show ?thesis
    by blast
 qed

lemma chinese_remainder_nat:
  fixes A :: "'a set"
    and m :: "'a \<Rightarrow> nat"
    and u :: "'a \<Rightarrow> nat"
  assumes fin: "finite A"
    and cop: "\<forall>i \<in> A. \<forall>j \<in> A. i \<noteq> j \<longrightarrow> coprime (m i) (m j)"
  shows "\<exists>x. \<forall>i \<in> A. [x = u i] (mod m i)"
proof -
  have "\<exists>b. (\<forall>i \<in> A. [b i = 1] (mod m i) \<and> [b i = 0] (mod (\<Prod>j \<in> A - {i}. m j)))"
  proof (rule finite_set_choice, rule fin, rule ballI)
    fix i
    assume "i \<in> A"
    with cop have "coprime (\<Prod>j \<in> A - {i}. m j) (m i)"
      by (intro prod_coprime_left) auto
    then have "\<exists>x. [(\<Prod>j \<in> A - {i}. m j) * x = Suc 0] (mod m i)"
      by (elim cong_solve_coprime_nat)
    then obtain x where "[(\<Prod>j \<in> A - {i}. m j) * x = 1] (mod m i)"
      by auto
    moreover have "[(\<Prod>j \<in> A - {i}. m j) * x = 0] (mod (\<Prod>j \<in> A - {i}. m j))"
      by (simp add: cong_0_iff)
    ultimately show "\<exists>a. [a = 1] (mod m i) \<and> [a = 0] (mod prod m (A - {i}))"
      by blast
  qed
  then obtain b where b: "\<And>i. i \<in> A \<Longrightarrow> [b i = 1] (mod m i) \<and> [b i = 0] (mod (\<Prod>j \<in> A - {i}. m j))"
    by blast
  let ?x = "\<Sum>i\<in>A. (u i) * (b i)"
  show ?thesis
  proof (rule exI, clarify)
    fix i
    assume a: "i \<in> A"
    show "[?x = u i] (mod m i)"
    proof -
      from fin a have "?x = (\<Sum>j \<in> {i}. u j * b j) + (\<Sum>j \<in> A - {i}. u j * b j)"
        by (subst sum.union_disjoint [symmetric]) (auto intro: sum.cong)
      then have "[?x = u i * b i + (\<Sum>j \<in> A - {i}. u j * b j)] (mod m i)"
        by auto
      also have "[u i * b i + (\<Sum>j \<in> A - {i}. u j * b j) =
                  u i * 1 + (\<Sum>j \<in> A - {i}. u j * 0)] (mod m i)"
      proof (intro cong_add cong_scalar_left cong_sum)
        show "[b i = 1] (mod m i)"
          using a b by blast
        show "[b x = 0] (mod m i)" if "x \<in> A - {i}" for x
        proof -
          have "x \<in> A" "x \<noteq> i"
            using that by auto
          then show ?thesis
            using a b [OF \<open>x \<in> A\<close>] cong_dvd_modulus_nat fin by blast
        qed
      qed
      finally show ?thesis
        by simp
    qed
  qed
qed

lemma coprime_cong_prod_nat: "[x = y] (mod (\<Prod>i\<in>A. m i))"
  if "\<And>i j. \<lbrakk>i \<in> A; j \<in> A; i \<noteq> j\<rbrakk> \<Longrightarrow> coprime (m i) (m j)"
    and "\<And>i. i \<in> A \<Longrightarrow> [x = y] (mod m i)" for x y :: nat
  using that
proof (induct A rule: infinite_finite_induct)
  case (insert x A)
  then show ?case
    by simp (metis coprime_cong_mult_nat prod_coprime_right)
qed auto

lemma chinese_remainder_unique_nat:
  fixes A :: "'a set"
    and m :: "'a \<Rightarrow> nat"
    and u :: "'a \<Rightarrow> nat"
  assumes fin: "finite A"
    and nz: "\<forall>i\<in>A. m i \<noteq> 0"
    and cop: "\<forall>i\<in>A. \<forall>j\<in>A. i \<noteq> j \<longrightarrow> coprime (m i) (m j)"
  shows "\<exists>!x. x < (\<Prod>i\<in>A. m i) \<and> (\<forall>i\<in>A. [x = u i] (mod m i))"
proof -
  from chinese_remainder_nat [OF fin cop]
  obtain y where one: "(\<forall>i\<in>A. [y = u i] (mod m i))"
    by blast
  let ?x = "y mod (\<Prod>i\<in>A. m i)"
  from fin nz have prodnz: "(\<Prod>i\<in>A. m i) \<noteq> 0"
    by auto
  then have less: "?x < (\<Prod>i\<in>A. m i)"
    by auto
  have cong: "\<forall>i\<in>A. [?x = u i] (mod m i)"
    using fin one
    by (auto simp add: cong_def dvd_prod_eqI mod_mod_cancel)
  have unique: "\<forall>z. z < (\<Prod>i\<in>A. m i) \<and> (\<forall>i\<in>A. [z = u i] (mod m i)) \<longrightarrow> z = ?x"
  proof clarify
    fix z
    assume zless: "z < (\<Prod>i\<in>A. m i)"
    assume zcong: "(\<forall>i\<in>A. [z = u i] (mod m i))"
    have "\<forall>i\<in>A. [?x = z] (mod m i)"
      using cong zcong by (auto simp add: cong_def)
    with fin cop have "[?x = z] (mod (\<Prod>i\<in>A. m i))"
      by (intro coprime_cong_prod_nat) auto
    with zless less show "z = ?x"
      by (auto simp add: cong_def)
  qed
  from less cong unique show ?thesis
    by blast
qed

end


(*  Title:       Defintion and basics facts about Cantor pairing function
    Author:      Michael Nedzelsky <MichaelNedzelsky at yandex.ru>, 2008
    Maintainer:  Michael Nedzelsky <MichaelNedzelsky at yandex.ru>
*)

section \<open>Cantor pairing function\<close>

theory CPair
imports Main
begin

text \<open>
  We introduce a particular coding \<open>c_pair\<close> from ordered pairs
  of natural numbers to natural numbers.  See \<^cite>\<open>"Rogers"\<close> and the
  Isabelle documentation for more information.
\<close>

subsection \<open>Pairing function\<close>

definition
  sf :: "nat \<Rightarrow> nat" where
  sf_def: "sf x = x * (x+1) div 2"

definition
  c_pair :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_pair x y = sf (x+y) + x"

lemma sf_at_0: "sf 0 = 0" by (simp add: sf_def)

lemma sf_at_1: "sf 1 = 1" by (simp add: sf_def)

lemma sf_at_Suc: "sf (x+1) = sf x + x + 1"
proof -
  have S1: "sf(x+1) = ((x+1)*(x+2)) div 2" by (simp add: sf_def)
  have S2: "(x+1)*(x+2) = x*(x+1) + 2*(x+1)" by (auto)
  have S2_1: "\<And> x y. x=y \<Longrightarrow> x div 2 = y div 2" by auto
  from S2 have S3: "(x+1)*(x+2) div 2 = (x*(x+1) + 2*(x+1)) div 2" by (rule S2_1)
  have S4: "(0::nat) < 2" by (auto)
  from S4 have S5: "(x*(x+1) + 2*(x+1)) div 2 = (x+1) + x*(x+1) div 2" by simp
  from S1 S3 S5 show ?thesis by (simp add: sf_def)
qed

lemma arg_le_sf: "x \<le> sf x"
proof -
  have "x + x \<le> x*(x + 1)" by simp
  hence "(x + x) div 2 \<le> x*(x+1) div 2" by (rule div_le_mono)
  hence "x \<le> x*(x+1) div 2" by simp
  thus ?thesis by (simp add: sf_def)
qed

lemma sf_mono: "x \<le> y \<Longrightarrow> sf x \<le> sf y"
proof -
  assume A1: "x \<le> y"
  then have "x+1 \<le> y+1" by (auto)
  with A1 have "x*(x+1) \<le> y*(y+1)" by (rule mult_le_mono)
  then have "x*(x+1) div 2 \<le> y*(y+1) div 2" by (rule div_le_mono)
  thus ?thesis by (simp add: sf_def)
qed

lemma sf_strict_mono: "x < y \<Longrightarrow> sf x < sf y"
proof -
  assume A1: "x < y"
  from A1 have S1: "x+1 \<le> y" by simp
  from S1 sf_mono have S2: "sf (x+1) \<le> sf y" by (auto)
  from sf_at_Suc have S3: "sf x < sf (x+1)" by (auto)
  from S2 S3 show ?thesis by (auto)
qed

lemma sf_posI: "x > 0 \<Longrightarrow> sf(x) > 0"
proof -
  assume A1: "x > 0"
  then have "sf(0) < sf(x)" by (rule sf_strict_mono)
  then show ?thesis by simp
qed

lemma arg_less_sf: "x > 1 \<Longrightarrow> x < sf(x)"
proof -
  assume A1: "x > 1"
  let ?y = "x-(1::nat)"
  from A1 have S1: "x = ?y+1" by simp
  from A1 have "?y > 0" by simp
  then have S2: "sf(?y) > 0" by (rule sf_posI)
  have "sf(?y+1) = sf(?y) + ?y + 1" by (rule sf_at_Suc)
  with S1 have "sf(x) = sf(?y) + x" by simp
  with S2  show ?thesis by simp
qed

lemma sf_eq_arg: "sf x = x \<Longrightarrow> x \<le> 1"
proof -
  assume "sf(x) = x"
  then have "\<not> (x < sf(x))" by simp
  then have "(\<not> (x > 1))" by (auto simp add: arg_less_sf)
  then show ?thesis by simp
qed

lemma sf_le_sfD: "sf x \<le> sf y \<Longrightarrow> x \<le> y"
proof -
  assume A1: "sf x \<le> sf y"
  have S1: "y < x \<Longrightarrow> sf y < sf x" by (rule sf_strict_mono)
  have S2: "y < x \<or> x \<le> y" by (auto)
  from A1 S1 S2 show ?thesis by (auto)
qed

lemma sf_less_sfD: "sf x < sf y \<Longrightarrow> x < y"
proof -
  assume A1: "sf x < sf y"
  have S1: "y \<le> x \<Longrightarrow> sf y \<le> sf x" by (rule sf_mono)
  have S2: "y \<le> x \<or> x < y" by (auto)
  from A1 S1 S2 show ?thesis by (auto)
qed

lemma sf_inj: "sf x = sf y \<Longrightarrow> x = y"
proof -
  assume A1: "sf x = sf y"
  have S1: "sf x \<le> sf y \<Longrightarrow> x \<le> y" by (rule sf_le_sfD)
  have S2: "sf y \<le> sf x \<Longrightarrow> y \<le> x" by (rule sf_le_sfD)
  from A1 have S3: "sf x \<le> sf y \<and> sf y \<le> sf x" by (auto)
  from S3 S1 S2 have S4: "x \<le> y \<and> y \<le> x" by (auto)
  from S4 show ?thesis by (auto)
qed

text \<open>Auxiliary lemmas\<close>

lemma sf_aux1: "x + y < z \<Longrightarrow> sf(x+y) + x < sf(z)"
proof -
  assume A1: "x+y < z"
  from A1 have S1: "x+y+1 \<le> z" by (auto)
  from S1 have S2: "sf(x+y+1) \<le> sf(z)" by (rule sf_mono)
  have S3: "sf(x+y+1) = sf(x+y) + (x+y)+1" by (rule sf_at_Suc)
  from S3 S2 have S4: "sf(x+y) + (x+y) + 1 \<le> sf(z)" by (auto)
  from S4 show ?thesis by (auto)
qed

lemma sf_aux2: "sf(z) \<le> sf(x+y) + x \<Longrightarrow> z \<le> x+y"
proof -
  assume A1: "sf(z) \<le> sf(x+y) + x"
  from A1 have S1: "\<not> sf(x+y) +x < sf(z)" by (auto)
  from S1 sf_aux1 have S2: "\<not> x+y < z" by (auto)
  from S2 show ?thesis by (auto)
qed

lemma sf_aux3: "sf(z) + m < sf(z+1) \<Longrightarrow> m \<le> z"
proof -
  assume A1: "sf(z) + m < sf(z+1)"
  have S1: "sf(z+1) = sf(z) + z + 1" by (rule sf_at_Suc)
  from A1 S1 have S2: "sf(z) + m < sf(z) + z + 1" by (auto)
  from S2 have S3: "m < z + 1" by (auto)
  from S3 show ?thesis by (auto)
qed

lemma sf_aux4: "(s::nat) < t \<Longrightarrow> (sf s) + s < sf t"
proof -
  assume A1: "(s::nat) < t"
  have "s*(s + 1) + 2*(s+1) \<le> t*(t+1)"
  proof -
    from A1 have S1: "(s::nat) + 1 \<le> t" by (auto)
    from A1 have "(s::nat) + 2 \<le> t+1" by (auto)
    with S1 have "((s::nat)+1)*(s+2) \<le> t*(t+1)" by (rule mult_le_mono)
    thus ?thesis by (auto)
  qed
  then have S1: "(s*(s+1) + 2*(s+1)) div 2 \<le>  t*(t+1) div 2" by (rule div_le_mono)
  have "(0::nat) < 2" by (auto)
  then have "(s*(s+1) + 2*(s+1)) div 2 = (s+1) + (s*(s+1)) div 2" by simp
  with S1 have "(s*(s+1)) div 2 + (s+1) \<le> t*(t+1) div 2" by (auto)
  then have "(s*(s+1)) div 2 + s < t*(t+1) div 2" by (auto)
  thus ?thesis by (simp add: sf_def)
qed

text \<open>Basic properties of c\_pair function\<close>

lemma sum_le_c_pair: "x + y \<le> c_pair x y"
proof -
  have "x+y \<le> sf(x+y)" by (rule arg_le_sf)
  thus ?thesis by (simp add: c_pair_def)
qed

lemma arg1_le_c_pair: "x \<le> c_pair x y"
proof -
  have "(x::nat) \<le> x + y" by (simp)
  moreover have "x + y \<le> c_pair x y" by (rule sum_le_c_pair)
  ultimately show ?thesis by (simp)
qed

lemma arg2_le_c_pair: "y \<le> c_pair x y"
proof -
  have "(y::nat) \<le> x + y" by (simp)
  moreover have "x + y \<le> c_pair x y" by (rule sum_le_c_pair)
  ultimately show ?thesis by (simp)
qed

lemma c_pair_sum_mono: "(x1::nat) + y1 < x2 + y2 \<Longrightarrow> c_pair x1 y1 < c_pair x2 y2"
proof -
  assume "(x1::nat) + y1 < x2 + y2"
  hence "sf (x1+y1) + (x1+y1) < sf(x2+y2)" by (rule sf_aux4)
  hence "sf (x1+y1) + x1 < sf(x2+y2) + x2" by (auto)
  thus ?thesis by (simp add: c_pair_def)
qed

lemma c_pair_sum_inj: "c_pair x1 y1 = c_pair x2 y2 \<Longrightarrow> x1 + y1 = x2 + y2"
proof -
  assume A1: "c_pair x1 y1 = c_pair x2 y2"
  have S1: "(x1::nat) + y1 < x2 + y2 \<Longrightarrow> c_pair x1 y1 \<noteq> c_pair x2 y2" by (rule less_not_refl3, rule c_pair_sum_mono, auto)
  have S2: "(x2::nat) + y2 < x1 + y1 \<Longrightarrow> c_pair x1 y1 \<noteq> c_pair x2 y2" by (rule less_not_refl2, rule c_pair_sum_mono, auto)
  from S1 S2 have "(x1::nat) + y1 \<noteq> x2 + y2 \<Longrightarrow> c_pair x1 y1 \<noteq> c_pair x2 y2" by (arith)
  with A1 show ?thesis by (auto)
qed

lemma c_pair_inj: "c_pair x1 y1 = c_pair x2 y2 \<Longrightarrow> x1 = x2 \<and> y1 = y2"
proof -
  assume A1: "c_pair x1 y1 = c_pair x2 y2"
  from A1 have S1: "x1 + y1 = x2 + y2" by (rule c_pair_sum_inj)
  from A1 have S2: "sf (x1+y1) + x1 = sf (x2+y2) + x2" by (unfold c_pair_def)
  from S1 S2 have S3: "x1 = x2" by (simp)
  from S1 S3 have S4: "y1 = y2" by (simp)
  from S3 S4 show ?thesis by (auto)
qed

lemma c_pair_inj1: "c_pair x1 y1 = c_pair x2 y2 \<Longrightarrow> x1 = x2" by (frule c_pair_inj, drule conjunct1)

lemma c_pair_inj2: "c_pair x1 y1 = c_pair x2 y2 \<Longrightarrow> y1 = y2" by (frule c_pair_inj, drule conjunct2)

lemma c_pair_strict_mono1: "x1 < x2 \<Longrightarrow> c_pair x1 y < c_pair x2 y"
proof -
  assume "x1 < x2"
  then have "x1 + y < x2 + y" by simp
  then show ?thesis by (rule c_pair_sum_mono)
qed

lemma c_pair_mono1: "x1 \<le> x2 \<Longrightarrow> c_pair x1 y \<le> c_pair x2 y"
proof -
  assume A1: "x1 \<le> x2"
  show ?thesis
  proof cases
    assume "x1 < x2"
    then have "c_pair x1 y < c_pair x2 y" by (rule c_pair_strict_mono1)
    then show ?thesis by simp
  next
    assume "\<not> x1 < x2"
    with A1 have "x1 = x2" by simp
    then show ?thesis by simp
  qed
qed

lemma c_pair_strict_mono2: "y1 < y2 \<Longrightarrow> c_pair x y1 < c_pair x y2"
proof -
  assume A1: "y1 < y2"
  from A1 have S1: "x + y1 < x + y2" by simp
  then show ?thesis by (rule c_pair_sum_mono)
qed

lemma c_pair_mono2: "y1 \<le> y2 \<Longrightarrow> c_pair x y1 \<le> c_pair x y2"
proof -
  assume A1: "y1 \<le> y2"
  show ?thesis
  proof cases
    assume "y1 < y2"
    then have "c_pair x y1 < c_pair x y2" by (rule c_pair_strict_mono2)
    then show ?thesis by simp
  next
    assume "\<not> y1 < y2"
    with A1 have "y1 = y2" by simp
    then show ?thesis by simp
  qed
qed

subsection \<open>Inverse mapping\<close>

text \<open>
  \<open>c_fst\<close> and \<open>c_snd\<close> are the functions which yield
  the inverse mapping to \<open>c_pair\<close>.
\<close>

definition
  c_sum :: "nat \<Rightarrow> nat" where
  "c_sum u = (LEAST z. u < sf (z+1))"

definition
  c_fst :: "nat \<Rightarrow> nat" where
  "c_fst u = u - sf (c_sum u)"

definition
  c_snd :: "nat \<Rightarrow> nat" where
  "c_snd u = c_sum u - c_fst u"

lemma arg_less_sf_at_Suc_of_c_sum: "u < sf ((c_sum u) + 1)"
proof -
  have "u+1 \<le> sf(u+1)" by (rule arg_le_sf)
  hence "u < sf(u+1)" by simp
  thus ?thesis by (unfold c_sum_def, rule LeastI)
qed

lemma arg_less_sf_imp_c_sum_less_arg: "u < sf(x) \<Longrightarrow> c_sum u < x"
proof -
  assume A1: "u < sf(x)"
  then show ?thesis
  proof (cases x)
    assume "x=0"
    with A1 show ?thesis by (simp add: sf_def)
  next
    fix y
    assume A2: "x = Suc y"
    show ?thesis
    proof -
      from A1 A2 have "u < sf(y+1)" by simp
      hence "(Least (%z. u < sf (z+1))) \<le> y" by (rule Least_le)
      hence "c_sum u \<le> y" by (fold c_sum_def)
      with A2 show ?thesis by simp
    qed
  qed
qed

lemma sf_c_sum_le_arg: "u \<ge> sf (c_sum u)"
proof -
  let ?z = "c_sum u"
  from arg_less_sf_at_Suc_of_c_sum have S1: "u < sf (?z+1)" by (auto)
  have S2: "\<not> c_sum u < c_sum u" by (auto)
  from arg_less_sf_imp_c_sum_less_arg S2 have S3: "\<not> u < sf (c_sum u) " by (auto)
  from S3 show ?thesis by (auto)
qed

lemma c_sum_le_arg: "c_sum u \<le> u"
proof -
  have "c_sum u \<le> sf (c_sum u)" by (rule arg_le_sf)
  moreover have "sf(c_sum u) \<le> u" by (rule sf_c_sum_le_arg)
  ultimately show ?thesis by simp
qed

lemma c_sum_of_c_pair [simp]: "c_sum (c_pair x y) = x + y"
proof -
  let ?u = "c_pair x y"
  let ?z = "c_sum ?u"
  have S1: "?u < sf(?z+1)" by (rule arg_less_sf_at_Suc_of_c_sum)
  have S2: "sf(?z) \<le> ?u" by (rule sf_c_sum_le_arg)
  from S1 have S3: "sf(x+y)+x < sf(?z+1)" by (simp add: c_pair_def)
  from S2 have S4: "sf(?z) \<le> sf(x+y) + x" by (simp add: c_pair_def)
  from S3 have S5: "sf(x+y) < sf(?z+1)" by (auto)
  from S5 have S6: "x+y < ?z+1" by (rule sf_less_sfD)
  from S6 have S7: "x+y \<le> ?z" by (auto)
  from S4 have S8: "?z \<le> x+y" by (rule sf_aux2)
  from S7 S8 have S9: "?z = x+y" by (auto)
  from S9 show ?thesis by (simp)
qed

lemma c_fst_of_c_pair[simp]: "c_fst (c_pair x y) = x"
proof -
  let ?u = "c_pair x y"
  have "c_sum ?u = x + y" by simp
  hence "c_fst ?u = ?u - sf(x+y)" by (simp add: c_fst_def)
  moreover have "?u = sf(x+y) + x" by (simp add: c_pair_def)
  ultimately show ?thesis by (simp)
qed

lemma c_snd_of_c_pair[simp]: "c_snd (c_pair x y) = y"
proof -
  let ?u = "c_pair x y"
  have "c_sum ?u = x + y" by simp
  moreover have "c_fst ?u = x" by simp
  ultimately show ?thesis by (simp add: c_snd_def)
qed

lemma c_pair_at_0: "c_pair 0 0 = 0" by (simp add: sf_def c_pair_def)

lemma c_fst_at_0: "c_fst 0 = 0"
proof -
  have "c_pair 0 0 = 0" by (rule c_pair_at_0)
  hence "c_fst 0 = c_fst (c_pair 0 0)" by simp
  thus ?thesis by simp
qed

lemma c_snd_at_0: "c_snd 0 = 0"
proof -
  have "c_pair 0 0 = 0" by (rule c_pair_at_0)
  hence "c_snd 0 = c_snd (c_pair 0 0)" by simp
  thus ?thesis by simp
qed

lemma sf_c_sum_plus_c_fst: "sf(c_sum u) + c_fst u = u"
proof -
  have S1: "sf(c_sum u) \<le> u" by (rule sf_c_sum_le_arg)
  have S2: "c_fst u = u - sf(c_sum u)" by (simp add: c_fst_def)
  from S1 S2 show ?thesis by (auto)
qed

lemma c_fst_le_c_sum: "c_fst u \<le> c_sum u"
proof -
  have S1: "sf(c_sum u) + c_fst u = u" by (rule sf_c_sum_plus_c_fst)
  have S2: "u < sf((c_sum u) + 1)" by (rule arg_less_sf_at_Suc_of_c_sum)
  from S1 S2 sf_aux3 show ?thesis by (auto)
qed

lemma c_snd_le_c_sum: "c_snd u \<le> c_sum u" by (simp add: c_snd_def)

lemma c_fst_le_arg: "c_fst u \<le> u"
proof -
  have "c_fst u \<le> c_sum u" by (rule c_fst_le_c_sum)
  moreover have "c_sum u \<le> u" by (rule c_sum_le_arg)
  ultimately show ?thesis by simp
qed

lemma c_snd_le_arg: "c_snd u \<le> u"
proof -
  have "c_snd u \<le> c_sum u" by (rule c_snd_le_c_sum)
  moreover have "c_sum u \<le> u" by (rule c_sum_le_arg)
  ultimately show ?thesis by simp
qed

lemma c_sum_is_sum: "c_sum u = c_fst u + c_snd u" by (simp add: c_snd_def c_fst_le_c_sum)

lemma proj_eq_imp_arg_eq: "\<lbrakk> c_fst u = c_fst v; c_snd u = c_snd v\<rbrakk> \<Longrightarrow> u = v"
proof -
  assume A1: "c_fst u = c_fst v"
  assume A2: "c_snd u = c_snd v"
  from A1 A2 c_sum_is_sum have S1: "c_sum u = c_sum v" by (auto)
  have S2: "sf(c_sum u) + c_fst u = u" by (rule sf_c_sum_plus_c_fst)
  from A1 S1 S2 have S3: "sf(c_sum v) + c_fst v = u" by (auto)
  from S3 sf_c_sum_plus_c_fst show ?thesis by (auto)
qed

lemma c_pair_of_c_fst_c_snd[simp]: "c_pair (c_fst u) (c_snd u) = u"
proof -
  let ?x = "c_fst u"
  let ?y = "c_snd u"
  have S1: "c_pair ?x ?y = sf(?x + ?y) + ?x" by (simp add: c_pair_def)
  have S2: "c_sum u = ?x + ?y" by (rule c_sum_is_sum)
  from S1 S2 have "c_pair ?x ?y = sf(c_sum u) + c_fst u" by (auto)
  thus ?thesis by (simp add: sf_c_sum_plus_c_fst)
qed

lemma c_sum_eq_arg: "c_sum x = x \<Longrightarrow> x \<le> 1"
proof -
  assume A1: "c_sum x = x"
  have S1: "sf(c_sum x) + c_fst x = x" by (rule sf_c_sum_plus_c_fst)
  from A1 S1 have S2: "sf x + c_fst x = x" by simp
  have S3: "x \<le> sf x" by (rule arg_le_sf)
  from S2 S3 have "sf(x)=x" by simp
  thus ?thesis by (rule sf_eq_arg)
qed

lemma c_sum_eq_arg_2: "c_sum x = x \<Longrightarrow> c_fst x = 0"
proof -
  assume A1: "c_sum x = x"
  have S1: "sf(c_sum x) + c_fst x = x" by (rule sf_c_sum_plus_c_fst)
  from A1 S1 have S2: "sf x + c_fst x = x" by simp
  have S3: "x \<le> sf x" by (rule arg_le_sf)
  from S2 S3 show ?thesis by simp
qed

lemma c_fst_eq_arg: "c_fst x = x \<Longrightarrow> x = 0"
proof -
  assume A1: "c_fst x = x"
  have S1: "c_fst x \<le> c_sum x" by (rule c_fst_le_c_sum)
  have S2: "c_sum x \<le> x" by (rule c_sum_le_arg)
  from A1 S1 S2 have "c_sum x = x" by simp
  then have "c_fst x = 0" by (rule c_sum_eq_arg_2)
  with A1 show ?thesis by simp
qed

lemma c_snd_eq_arg: "c_snd x = x \<Longrightarrow> x \<le> 1"
proof -
  assume A1: "c_snd x = x"
  have S1: "c_snd x \<le> c_sum x" by (rule c_snd_le_c_sum)
  have S2: "c_sum x \<le> x" by (rule c_sum_le_arg)
  from A1 S1 S2 have "c_sum x = x" by simp
  then show ?thesis by (rule c_sum_eq_arg)
qed

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_sort_nat_MSortBU2Count
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(Nat list) list => (Nat list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu2 :: "(Nat list) list => Nat list" where
  "mergingbu2 (nil2) = nil2"
| "mergingbu2 (cons2 xs (nil2)) = xs"
| "mergingbu2 (cons2 xs (cons2 z x2)) =
     mergingbu2 (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun risers :: "Nat list => (Nat list) list" where
  "risers (nil2) = nil2"
| "risers (cons2 y (nil2)) = cons2 (cons2 y (nil2)) (nil2)"
| "risers (cons2 y (cons2 y2 xs)) =
     (if le y y2 then
        (case risers (cons2 y2 xs) of
           nil2 => nil2
           | cons2 ys yss => cons2 (cons2 y ys) yss)
        else
        cons2 (cons2 y (nil2)) (risers (cons2 y2 xs)))"

fun msortbu2 :: "Nat list => Nat list" where
  "msortbu2 x = mergingbu2 (risers x)"

fun count :: "'a => 'a list => Nat" where
  "count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((count x (msortbu2 xs)) = (count x xs))"
  oops

end


\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>Pigeonhole\<close>
theory Pigeonhole
  imports Main
begin

paragraph \<open>Summary\<close>
text \<open>We introduce the generalized pigeonhole principle (which is/was not available in
Isabelle when formalizing it here).

Additionally, we introduce an auxiliary lemma that uses the simple pigeonhole principle
to find a reoccurring element in a list and to decompose the list into three lists with
the reoccurring element as a split element.\<close>

lemma generalized_pigeonhole:
  assumes "dom f \<noteq> {}" "finite (dom f)" "card (dom f) \<ge> card (ran f) * k + 1"
  shows "\<exists>y \<in> ran f. card (f -` {Some y}) \<ge> k + 1"
proof (rule ccontr)
  assume "\<not> (\<exists>y\<in>ran f. k + 1 \<le> card (f -` {Some y}))"
  then have A: "\<And>y. y \<in> ran f \<Longrightarrow> card (f -` {Some y}) \<le> k"
    by auto

  have "finite (ran f)"
    using assms finite_ran by simp
  moreover have "dom f = (\<Union>y \<in> ran f. f -` {Some y})"
    unfolding dom_def ran_def by auto
  ultimately have "card (dom f) = (\<Sum>y \<in> ran f. card (f -` {Some y}))"
    using assms by (auto intro: card_UN_disjoint)
  also have "... \<le> (\<Sum>y \<in> ran f. k)"
    using sum_mono[OF A] by simp
  also have "... < card (ran f) * k + 1"
    by simp
  also have "... \<le> card (dom f)"
    using assms by simp
  finally show False ..
qed

lemma pigeonhole_ex:
  assumes "length fs \<ge> card N + 1" "set fs \<subseteq> N" "finite N"
  shows "\<exists>i j. i < j \<and> j < length fs \<and> fs!i = fs!j"
proof -
  let ?f = "\<lambda>n. if n < length fs then fs!n else undefined"
  let ?d = "{0..<length fs}"
  have "?f ` ?d \<subseteq> set fs"
    by auto
  then have "?f ` ?d \<subseteq> N"
    using assms by blast
  then have "card (?f ` ?d) + 1 \<le> length fs"
    using card_mono[of "N" "?f ` ?d"] assms by simp
  moreover have "card (set fs) \<le> card ?d"
    by (simp add: card_length)
  ultimately have "\<not> inj_on ?f ?d"
    using pigeonhole[of ?f ?d] by simp
  then obtain x y where *: "x \<in> ?d" "y \<in> ?d" "x \<noteq> y" "?f x = ?f y"
    unfolding inj_on_def by blast
  then have "fs!x = fs !y"
    by auto
  then show "\<exists>i j. i < j \<and> j < length fs \<and> fs ! i = fs ! j"
    using *
    apply (cases "x < y")
     apply auto[1]
    by (rule exI[where x="y"], rule exI[where x="x"], simp)
qed

lemma pigeonhole_split_list:
  assumes "length fs \<ge> card N + 1" "set fs \<subseteq> N" "finite N"
  shows "\<exists>x xs ys zs. fs = xs @ x # ys @ x # zs"
proof -
  obtain i j where "i < j" "j < length fs" "fs!i = fs!j"
    using pigeonhole_ex assms by blast
  then have "\<not> distinct fs"
    using distinct_conv_nth[of fs] by auto
  then obtain xs ys zs y where **: "fs = xs @ [y] @ ys @ [y] @ zs"
    using not_distinct_decomp[of fs] by blast
  then show ?thesis
    by auto
qed

end


text\<open> 4 Nov 2021: Two lemmas for Homework 09 in CS 511 \<close>

theory HW09_solution
  imports Main
begin

text \<open> Exercise 1 on the last page of Lecture Slides 28, Analytic Tableaux
       Part I  \<close>

lemma A1 : " (\<forall>x. \<forall>y. \<forall>z. P(x,y) \<and> P(y,z) \<longrightarrow> P(x,z)) \<and> (\<forall>x. \<forall>y. P(x,y) \<longrightarrow> P(y,x))
            \<Longrightarrow> \<forall>x. \<forall>y. \<forall>z. P(x,y) \<and> P(z,y) \<longrightarrow> P(x,z) "
  by blast

lemma A2 : " (\<forall>x. \<forall>y. \<forall>z. P(x,y) \<and> P(y,z) \<longrightarrow> P(x,z)) \<and> (\<forall>x. \<forall>y. P(x,y) \<longrightarrow> P(y,x))
               \<Longrightarrow> \<forall>x. \<forall>y. \<forall>z. P(x,y) \<and> P(z,y) \<longrightarrow> P(x,z) "
  apply (erule conjE)
  apply (rule allI)+
  apply (rule impI)
  apply (erule conjE)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="z" in allE)
  apply (erule_tac x="y" in allE)
  apply (erule_tac x="y" in allE)
  apply (erule_tac x="z" in allE)
  apply (erule impE)
   apply assumption
  apply (erule impE)
   apply (rule conjI)
  apply assumption+
  done

text \<open> Exercise 2 on the last page of Lecture Slides 28, Analytic Tableaux
       Part I  \<close>
lemma B1: "\<forall>x. Q(a,x,x) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow>
    Q(x,s(y),s(z))) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow> Q(y,x,z)) \<Longrightarrow> \<exists> x. Q( s(s(a)), s(s(s(a))), x) "
  by blast

text \<open> A bloated proof of Lemma B1 with several unnecessary 'apply' steps \<close>
lemma B2: "(\<forall>x. Q(a,x,x)) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow>
    Q(x,s(y),s(z))) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow> Q(y,x,z)) \<Longrightarrow> \<exists> x. Q( s(s(a)), s(s(s(a))), x)"
  apply (erule conjE)
  apply (erule conjE)
  apply (rule_tac x="s(s(s(s(s(a)))))" in exI)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="a" in allE)
  apply (frule_tac x="a" in spec)
  apply (frule_tac x="s(a)" in spec)
  apply (frule_tac x="s(s(a))" in spec)
  apply (erule_tac x="a" in allE)
  apply (frule_tac x="a" in spec)
  apply (frule_tac x="s(s(a))" in spec)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(s(a)))" in allE)
  apply (erule_tac x="s(s(s(s(a))))" in allE)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="a" in allE)
  apply (erule impE)
   apply (erule mp)
   apply assumption
  apply (erule mp)
  apply (erule mp)
  apply assumption
  done

text \<open> The following proof is essentially the same as that for B2 above,
       the difference being that all explicit substitutions, except for one,
       are omitted. As a result, Isabelle will replace every quantified variable
       by a schematic variable, also trusting Isabelle's unification engine
       to figure out appropriate substitutions. \<close>
lemma B2_bis: "(\<forall>x. Q(a,x,x)) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow>
    Q(x,s(y),s(z))) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow> Q(y,x,z)) \<Longrightarrow> \<exists> x. Q( s(s(a)), s(s(s(a))), x)"
  apply (erule conjE)
  apply (erule conjE)
  apply (rule exI)
  apply (erule allE)
  apply (erule allE)
  apply (erule allE)
  apply (frule_tac x="a" in spec)
  apply (frule spec)
  apply (frule spec)
  apply (frule spec)
  apply (erule allE)
  apply (frule spec)
  apply (frule spec)
  apply (erule allE)
  apply (erule allE)
  apply (erule allE)
  apply (erule allE)
  apply (erule allE)
  apply (erule allE)
  apply (erule allE)
  apply (erule allE)
  apply (erule impE)
   apply (erule mp)
   apply assumption
  apply (erule mp)
  apply (erule mp)
  apply assumption
  done

text\<open> In the proofs to follow we use commands of the form: 'apply (rotate_tac n)'
      which rotates the premises of a subgoal by n positions, from RIGHT to LEFT
      if n is positive, and from LEFT to RIGHT if n is negative. \<close>

text \<open> Shortest proofs below are for Lemmas B3 and B4 \<close>

text \<open> A streamlined proof of Lemmas B1 and B2 with 12 'apply' steps \<close>
lemma B3: " (\<forall>x. Q(a,x,x)) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow>
    Q(x,s(y),s(z))) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow> Q(y,x,z)) \<Longrightarrow> \<exists> x. Q( s(s(a)), s(s(s(a))), x)"
  apply (erule conjE)+
  apply (rule_tac x="s(s(s(s(s(a)))))" in exI)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="a" in allE)
      (* rotate premises RIGHT to LEFT by 2 before applying rule 'allE' *)
  apply (rotate_tac 2, erule_tac x="s(s(a))" in allE)
      (* rotate premises RIGHT to LEFT by 2 before applying rule 'allE' *)
  apply (rotate_tac 2, erule_tac x="s(s(a))" in allE)
  apply (frule_tac x="a" in spec)
      (* rotate premises RIGHT to LEFT by 3 before applying rule 'allE' *)
  apply (rotate_tac 3, erule_tac x="s(s(a))" in allE)
  apply (frule_tac x="s(a)" in spec, rotate_tac 2, erule_tac x="s(s(s(a)))" in allE)
  apply (erule_tac x="s(s(a))" in allE, erule_tac x="s(s(s(s(a))))" in allE)
  apply (erule impE, assumption)+
  by assumption

text \<open> A slight variation of the proof of Lemma B3 with 13 'apply' steps \<close>
lemma B4: " (\<forall>x. Q(a,x,x)) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow>
    Q(x,s(y),s(z))) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow> Q(y,x,z)) \<Longrightarrow> \<exists> x. Q( s(s(a)), s(s(s(a))), x)"
  apply (erule conjE)+
  apply (rule exI)
  apply (erule allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="a" in allE)
      (* rotate premises LEFT to RIGHT by 1 before applying rule 'allE' *)
  apply (rotate_tac -1, erule_tac x="s(s(a))" in allE)
      (* rotate premises LEFT to RIGHT by 1 before applying rule 'allE' *)
  apply (rotate_tac -1, erule_tac x="s(s(a))" in allE)
  apply (frule_tac x="a" in spec)
      (* rotate premises RIGHT to LEFT by 3 before applying rule 'allE' *)
  apply (rotate_tac 3, erule_tac x="s(s(a))" in allE)
  apply (frule_tac x="s(a)" in spec, rotate_tac 2, erule_tac x="s(s(s(a)))" in allE)
  apply (erule_tac x="s(s(a))" in allE, erule_tac x="s(s(s(s(a))))" in allE)
  apply (erule impE, assumption)+
  apply assumption
  done

text \<open> The proofs of Lemmas B5 and B6 are obtained from the proof of B2 by
       repeated trial-error-backtrack steps \<close>

text \<open> A shorter proof of Lemmas B1 and B2 with 19 'apply' steps, but still bloated \<close>
lemma B5: " (\<forall>x. Q(a,x,x)) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow>
    Q(x,s(y),s(z))) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow> Q(y,x,z)) \<Longrightarrow> \<exists> x. Q( s(s(a)), s(s(s(a))), x)"
  apply (erule conjE)+
  apply (rule_tac x="s(s(s(s(s(a)))))" in exI)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="a" in allE)
  apply (frule_tac x="a" in spec)
  apply (frule_tac x="s(a)" in spec)
  apply (erule_tac x="s(s(a))" in allE)
  apply (frule_tac x="a" in spec)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(s(a)))" in allE)
  apply (erule_tac x="s(s(s(s(a))))" in allE)
  apply (erule_tac x="s(s(s(s(a))))" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule impE)
   apply (erule mp)
   apply assumption
  apply (erule mp)+
  by assumption

text \<open> A shorter proof of Lemmas B1 and B2 with 21 'apply' steps, but still bloated \<close>
lemma B6: " (\<forall>x. Q(a,x,x)) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow>
    Q(x,s(y),s(z))) \<and> (\<forall>x y z. Q(x,y,z) \<longrightarrow> Q(y,x,z)) \<Longrightarrow> \<exists> x. Q( s(s(a)), s(s(s(a))), x)"
  apply (erule conjE)+
  apply (rule_tac x="s(s(s(s(s(a)))))" in exI)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (rotate_tac 2)
  apply (frule_tac x="a" in spec)
  apply (frule_tac x="s(a)" in spec)
  apply (erule_tac x="s(s(a))" in allE)
  apply (frule_tac x="a" in spec)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule_tac x="s(s(s(a)))" in allE)
  apply (erule_tac x="s(s(s(s(a))))" in allE)
  apply (erule_tac x="s(s(a))" in allE)
  apply (erule impE)
   apply (rotate_tac 4)
   apply (erule_tac x="s(s(a))" in allE)
   apply (erule mp)
  apply assumption
   apply (erule mp)
  apply (erule mp)
  by assumption

end