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

section {* Traces, Determinant of square matrices and some properties *}

theory Determinants
imports
  Cartesian_Euclidean_Space
  "~~/src/HOL/Library/Permutations"
begin

subsection{* First some facts about products*}

lemma setprod_add_split:
  fixes m n :: nat
  assumes mn: "m \<le> n + 1"
  shows "setprod f {m..n+p} = setprod f {m .. n} * setprod f {n+1..n+p}"
proof -
  let ?A = "{m..n+p}"
  let ?B = "{m..n}"
  let ?C = "{n+1..n+p}"
  from mn have un: "?B \<union> ?C = ?A"
    by auto
  from mn have dj: "?B \<inter> ?C = {}"
    by auto
  have f: "finite ?B" "finite ?C"
    by simp_all
  from setprod.union_disjoint[OF f dj, of f, unfolded un] show ?thesis .
qed

lemma setprod_offset:
  fixes m n :: nat
  shows "setprod f {m + p .. n + p} = setprod (\<lambda>i. f (i + p)) {m..n}"
  by (rule setprod.reindex_bij_witness[where i="op + p" and j="\<lambda>i. i - p"]) auto

lemma setprod_singleton: "setprod f {x} = f x"
  by simp

lemma setprod_singleton_nat_seg:
  fixes n :: "'a::order"
  shows "setprod f {n..n} = f n"
  by simp

lemma setprod_numseg:
  "setprod f {m..0} = (if m = 0 then f 0 else 1)"
  "setprod f {m .. Suc n} =
    (if m \<le> Suc n then f (Suc n) * setprod f {m..n} else setprod f {m..n})"
  by (auto simp add: atLeastAtMostSuc_conv)

lemma setprod_le:
  fixes f g :: "'b \<Rightarrow> 'a::linordered_idom"
  assumes fS: "finite S"
    and fg: "\<forall>x\<in>S. f x \<ge> 0 \<and> f x \<le> g x"
  shows "setprod f S \<le> setprod g S"
  using fS fg
  apply (induct S)
  apply simp
  apply auto
  apply (rule mult_mono)
  apply (auto intro: setprod_nonneg)
  done

(* FIXME: In Finite_Set there is a useless further assumption *)
lemma setprod_inversef:
  "finite A \<Longrightarrow> setprod (inverse \<circ> f) A = (inverse (setprod f A) :: 'a:: field_inverse_zero)"
  apply (erule finite_induct)
  apply (simp)
  apply simp
  done

lemma setprod_le_1:
  fixes f :: "'b \<Rightarrow> 'a::linordered_idom"
  assumes fS: "finite S"
    and f: "\<forall>x\<in>S. f x \<ge> 0 \<and> f x \<le> 1"
  shows "setprod f S \<le> 1"
  using setprod_le[OF fS f] unfolding setprod.neutral_const .

subsection {* Trace *}

definition trace :: "'a::semiring_1^'n^'n \<Rightarrow> 'a"
  where "trace A = setsum (\<lambda>i. ((A$i)$i)) (UNIV::'n set)"

lemma trace_0: "trace (mat 0) = 0"
  by (simp add: trace_def mat_def)

lemma trace_I: "trace (mat 1 :: 'a::semiring_1^'n^'n) = of_nat(CARD('n))"
  by (simp add: trace_def mat_def)

lemma trace_add: "trace ((A::'a::comm_semiring_1^'n^'n) + B) = trace A + trace B"
  by (simp add: trace_def setsum.distrib)

lemma trace_sub: "trace ((A::'a::comm_ring_1^'n^'n) - B) = trace A - trace B"
  by (simp add: trace_def setsum_subtractf)

lemma trace_mul_sym: "trace ((A::'a::comm_semiring_1^'n^'m) ** B) = trace (B**A)"
  apply (simp add: trace_def matrix_matrix_mult_def)
  apply (subst setsum.commute)
  apply (simp add: mult.commute)
  done

text {* Definition of determinant. *}

definition det:: "'a::comm_ring_1^'n^'n \<Rightarrow> 'a" where
  "det A =
    setsum (\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set))
      {p. p permutes (UNIV :: 'n set)}"

text {* A few general lemmas we need below. *}

lemma setprod_permute:
  assumes p: "p permutes S"
  shows "setprod f S = setprod (f \<circ> p) S"
  using assms by (fact setprod.permute)

lemma setproduct_permute_nat_interval:
  fixes m n :: nat
  shows "p permutes {m..n} \<Longrightarrow> setprod f {m..n} = setprod (f \<circ> p) {m..n}"
  by (blast intro!: setprod_permute)

text {* Basic determinant properties. *}

lemma det_transpose: "det (transpose A) = det (A::'a::comm_ring_1 ^'n^'n)"
proof -
  let ?di = "\<lambda>A i j. A$i$j"
  let ?U = "(UNIV :: 'n set)"
  have fU: "finite ?U" by simp
  {
    fix p
    assume p: "p \<in> {p. p permutes ?U}"
    from p have pU: "p permutes ?U"
      by blast
    have sth: "sign (inv p) = sign p"
      by (metis sign_inverse fU p mem_Collect_eq permutation_permutes)
    from permutes_inj[OF pU]
    have pi: "inj_on p ?U"
      by (blast intro: subset_inj_on)
    from permutes_image[OF pU]
    have "setprod (\<lambda>i. ?di (transpose A) i (inv p i)) ?U =
      setprod (\<lambda>i. ?di (transpose A) i (inv p i)) (p ` ?U)"
      by simp
    also have "\<dots> = setprod ((\<lambda>i. ?di (transpose A) i (inv p i)) \<circ> p) ?U"
      unfolding setprod.reindex[OF pi] ..
    also have "\<dots> = setprod (\<lambda>i. ?di A i (p i)) ?U"
    proof -
      {
        fix i
        assume i: "i \<in> ?U"
        from i permutes_inv_o[OF pU] permutes_in_image[OF pU]
        have "((\<lambda>i. ?di (transpose A) i (inv p i)) \<circ> p) i = ?di A i (p i)"
          unfolding transpose_def by (simp add: fun_eq_iff)
      }
      then show "setprod ((\<lambda>i. ?di (transpose A) i (inv p i)) \<circ> p) ?U =
        setprod (\<lambda>i. ?di A i (p i)) ?U"
        by (auto intro: setprod.cong)
    qed
    finally have "of_int (sign (inv p)) * (setprod (\<lambda>i. ?di (transpose A) i (inv p i)) ?U) =
      of_int (sign p) * (setprod (\<lambda>i. ?di A i (p i)) ?U)"
      using sth by simp
  }
  then show ?thesis
    unfolding det_def
    apply (subst setsum_permutations_inverse)
    apply (rule setsum.cong)
    apply (rule refl)
    apply blast
    done
qed

lemma det_lowerdiagonal:
  fixes A :: "'a::comm_ring_1^('n::{finite,wellorder})^('n::{finite,wellorder})"
  assumes ld: "\<And>i j. i < j \<Longrightarrow> A$i$j = 0"
  shows "det A = setprod (\<lambda>i. A$i$i) (UNIV:: 'n set)"
proof -
  let ?U = "UNIV:: 'n set"
  let ?PU = "{p. p permutes ?U}"
  let ?pp = "\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set)"
  have fU: "finite ?U"
    by simp
  from finite_permutations[OF fU] have fPU: "finite ?PU" .
  have id0: "{id} \<subseteq> ?PU"
    by (auto simp add: permutes_id)
  {
    fix p
    assume p: "p \<in> ?PU - {id}"
    from p have pU: "p permutes ?U" and pid: "p \<noteq> id"
      by blast+
    from permutes_natset_le[OF pU] pid obtain i where i: "p i > i"
      by (metis not_le)
    from ld[OF i] have ex:"\<exists>i \<in> ?U. A$i$p i = 0"
      by blast
    from setprod_zero[OF fU ex] have "?pp p = 0"
      by simp
  }
  then have p0: "\<forall>p \<in> ?PU - {id}. ?pp p = 0"
    by blast
  from setsum.mono_neutral_cong_left[OF fPU id0 p0] show ?thesis
    unfolding det_def by (simp add: sign_id)
qed

lemma det_upperdiagonal:
  fixes A :: "'a::comm_ring_1^'n::{finite,wellorder}^'n::{finite,wellorder}"
  assumes ld: "\<And>i j. i > j \<Longrightarrow> A$i$j = 0"
  shows "det A = setprod (\<lambda>i. A$i$i) (UNIV:: 'n set)"
proof -
  let ?U = "UNIV:: 'n set"
  let ?PU = "{p. p permutes ?U}"
  let ?pp = "(\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set))"
  have fU: "finite ?U"
    by simp
  from finite_permutations[OF fU] have fPU: "finite ?PU" .
  have id0: "{id} \<subseteq> ?PU"
    by (auto simp add: permutes_id)
  {
    fix p
    assume p: "p \<in> ?PU - {id}"
    from p have pU: "p permutes ?U" and pid: "p \<noteq> id"
      by blast+
    from permutes_natset_ge[OF pU] pid obtain i where i: "p i < i"
      by (metis not_le)
    from ld[OF i] have ex:"\<exists>i \<in> ?U. A$i$p i = 0"
      by blast
    from setprod_zero[OF fU ex] have "?pp p = 0"
      by simp
  }
  then have p0: "\<forall>p \<in> ?PU -{id}. ?pp p = 0"
    by blast
  from setsum.mono_neutral_cong_left[OF fPU id0 p0] show ?thesis
    unfolding det_def by (simp add: sign_id)
qed

lemma det_diagonal:
  fixes A :: "'a::comm_ring_1^'n^'n"
  assumes ld: "\<And>i j. i \<noteq> j \<Longrightarrow> A$i$j = 0"
  shows "det A = setprod (\<lambda>i. A$i$i) (UNIV::'n set)"
proof -
  let ?U = "UNIV:: 'n set"
  let ?PU = "{p. p permutes ?U}"
  let ?pp = "\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set)"
  have fU: "finite ?U" by simp
  from finite_permutations[OF fU] have fPU: "finite ?PU" .
  have id0: "{id} \<subseteq> ?PU"
    by (auto simp add: permutes_id)
  {
    fix p
    assume p: "p \<in> ?PU - {id}"
    then have "p \<noteq> id"
      by simp
    then obtain i where i: "p i \<noteq> i"
      unfolding fun_eq_iff by auto
    from ld [OF i [symmetric]] have ex:"\<exists>i \<in> ?U. A$i$p i = 0"
      by blast
    from setprod_zero [OF fU ex] have "?pp p = 0"
      by simp
  }
  then have p0: "\<forall>p \<in> ?PU - {id}. ?pp p = 0"
    by blast
  from setsum.mono_neutral_cong_left[OF fPU id0 p0] show ?thesis
    unfolding det_def by (simp add: sign_id)
qed

lemma det_I: "det (mat 1 :: 'a::comm_ring_1^'n^'n) = 1"
proof -
  let ?A = "mat 1 :: 'a::comm_ring_1^'n^'n"
  let ?U = "UNIV :: 'n set"
  let ?f = "\<lambda>i j. ?A$i$j"
  {
    fix i
    assume i: "i \<in> ?U"
    have "?f i i = 1"
      using i by (vector mat_def)
  }
  then have th: "setprod (\<lambda>i. ?f i i) ?U = setprod (\<lambda>x. 1) ?U"
    by (auto intro: setprod.cong)
  {
    fix i j
    assume i: "i \<in> ?U" and j: "j \<in> ?U" and ij: "i \<noteq> j"
    have "?f i j = 0" using i j ij
      by (vector mat_def)
  }
  then have "det ?A = setprod (\<lambda>i. ?f i i) ?U"
    using det_diagonal by blast
  also have "\<dots> = 1"
    unfolding th setprod.neutral_const ..
  finally show ?thesis .
qed

lemma det_0: "det (mat 0 :: 'a::comm_ring_1^'n^'n) = 0"
  by (simp add: det_def setprod_zero)

lemma det_permute_rows:
  fixes A :: "'a::comm_ring_1^'n^'n"
  assumes p: "p permutes (UNIV :: 'n::finite set)"
  shows "det (\<chi> i. A$p i :: 'a^'n^'n) = of_int (sign p) * det A"
  apply (simp add: det_def setsum_right_distrib mult.assoc[symmetric])
  apply (subst sum_permutations_compose_right[OF p])
proof (rule setsum.cong)
  let ?U = "UNIV :: 'n set"
  let ?PU = "{p. p permutes ?U}"
  fix q
  assume qPU: "q \<in> ?PU"
  have fU: "finite ?U"
    by simp
  from qPU have q: "q permutes ?U"
    by blast
  from p q have pp: "permutation p" and qp: "permutation q"
    by (metis fU permutation_permutes)+
  from permutes_inv[OF p] have ip: "inv p permutes ?U" .
  have "setprod (\<lambda>i. A$p i$ (q \<circ> p) i) ?U = setprod ((\<lambda>i. A$p i$(q \<circ> p) i) \<circ> inv p) ?U"
    by (simp only: setprod_permute[OF ip, symmetric])
  also have "\<dots> = setprod (\<lambda>i. A $ (p \<circ> inv p) i $ (q \<circ> (p \<circ> inv p)) i) ?U"
    by (simp only: o_def)
  also have "\<dots> = setprod (\<lambda>i. A$i$q i) ?U"
    by (simp only: o_def permutes_inverses[OF p])
  finally have thp: "setprod (\<lambda>i. A$p i$ (q \<circ> p) i) ?U = setprod (\<lambda>i. A$i$q i) ?U"
    by blast
  show "of_int (sign (q \<circ> p)) * setprod (\<lambda>i. A$ p i$ (q \<circ> p) i) ?U =
    of_int (sign p) * of_int (sign q) * setprod (\<lambda>i. A$i$q i) ?U"
    by (simp only: thp sign_compose[OF qp pp] mult.commute of_int_mult)
qed rule

lemma det_permute_columns:
  fixes A :: "'a::comm_ring_1^'n^'n"
  assumes p: "p permutes (UNIV :: 'n set)"
  shows "det(\<chi> i j. A$i$ p j :: 'a^'n^'n) = of_int (sign p) * det A"
proof -
  let ?Ap = "\<chi> i j. A$i$ p j :: 'a^'n^'n"
  let ?At = "transpose A"
  have "of_int (sign p) * det A = det (transpose (\<chi> i. transpose A $ p i))"
    unfolding det_permute_rows[OF p, of ?At] det_transpose ..
  moreover
  have "?Ap = transpose (\<chi> i. transpose A $ p i)"
    by (simp add: transpose_def vec_eq_iff)
  ultimately show ?thesis
    by simp
qed

lemma det_identical_rows:
  fixes A :: "'a::linordered_idom^'n^'n"
  assumes ij: "i \<noteq> j"
    and r: "row i A = row j A"
  shows "det A = 0"
proof-
  have tha: "\<And>(a::'a) b. a = b \<Longrightarrow> b = - a \<Longrightarrow> a = 0"
    by simp
  have th1: "of_int (-1) = - 1" by simp
  let ?p = "Fun.swap i j id"
  let ?A = "\<chi> i. A $ ?p i"
  from r have "A = ?A" by (simp add: vec_eq_iff row_def Fun.swap_def)
  then have "det A = det ?A" by simp
  moreover have "det A = - det ?A"
    by (simp add: det_permute_rows[OF permutes_swap_id] sign_swap_id ij th1)
  ultimately show "det A = 0" by (metis tha)
qed

lemma det_identical_columns:
  fixes A :: "'a::linordered_idom^'n^'n"
  assumes ij: "i \<noteq> j"
    and r: "column i A = column j A"
  shows "det A = 0"
  apply (subst det_transpose[symmetric])
  apply (rule det_identical_rows[OF ij])
  apply (metis row_transpose r)
  done

lemma det_zero_row:
  fixes A :: "'a::{idom, ring_char_0}^'n^'n"
  assumes r: "row i A = 0"
  shows "det A = 0"
  using r
  apply (simp add: row_def det_def vec_eq_iff)
  apply (rule setsum.neutral)
  apply (auto simp: sign_nz)
  done

lemma det_zero_column:
  fixes A :: "'a::{idom,ring_char_0}^'n^'n"
  assumes r: "column i A = 0"
  shows "det A = 0"
  apply (subst det_transpose[symmetric])
  apply (rule det_zero_row [of i])
  apply (metis row_transpose r)
  done

lemma det_row_add:
  fixes a b c :: "'n::finite \<Rightarrow> _ ^ 'n"
  shows "det((\<chi> i. if i = k then a i + b i else c i)::'a::comm_ring_1^'n^'n) =
    det((\<chi> i. if i = k then a i else c i)::'a::comm_ring_1^'n^'n) +
    det((\<chi> i. if i = k then b i else c i)::'a::comm_ring_1^'n^'n)"
  unfolding det_def vec_lambda_beta setsum.distrib[symmetric]
proof (rule setsum.cong)
  let ?U = "UNIV :: 'n set"
  let ?pU = "{p. p permutes ?U}"
  let ?f = "(\<lambda>i. if i = k then a i + b i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
  let ?g = "(\<lambda> i. if i = k then a i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
  let ?h = "(\<lambda> i. if i = k then b i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
  fix p
  assume p: "p \<in> ?pU"
  let ?Uk = "?U - {k}"
  from p have pU: "p permutes ?U"
    by blast
  have kU: "?U = insert k ?Uk"
    by blast
  {
    fix j
    assume j: "j \<in> ?Uk"
    from j have "?f j $ p j = ?g j $ p j" and "?f j $ p j= ?h j $ p j"
      by simp_all
  }
  then have th1: "setprod (\<lambda>i. ?f i $ p i) ?Uk = setprod (\<lambda>i. ?g i $ p i) ?Uk"
    and th2: "setprod (\<lambda>i. ?f i $ p i) ?Uk = setprod (\<lambda>i. ?h i $ p i) ?Uk"
    apply -
    apply (rule setprod.cong, simp_all)+
    done
  have th3: "finite ?Uk" "k \<notin> ?Uk"
    by auto
  have "setprod (\<lambda>i. ?f i $ p i) ?U = setprod (\<lambda>i. ?f i $ p i) (insert k ?Uk)"
    unfolding kU[symmetric] ..
  also have "\<dots> = ?f k $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk"
    apply (rule setprod.insert)
    apply simp
    apply blast
    done
  also have "\<dots> = (a k $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk) + (b k$ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk)"
    by (simp add: field_simps)
  also have "\<dots> = (a k $ p k * setprod (\<lambda>i. ?g i $ p i) ?Uk) + (b k$ p k * setprod (\<lambda>i. ?h i $ p i) ?Uk)"
    by (metis th1 th2)
  also have "\<dots> = setprod (\<lambda>i. ?g i $ p i) (insert k ?Uk) + setprod (\<lambda>i. ?h i $ p i) (insert k ?Uk)"
    unfolding  setprod.insert[OF th3] by simp
  finally have "setprod (\<lambda>i. ?f i $ p i) ?U = setprod (\<lambda>i. ?g i $ p i) ?U + setprod (\<lambda>i. ?h i $ p i) ?U"
    unfolding kU[symmetric] .
  then show "of_int (sign p) * setprod (\<lambda>i. ?f i $ p i) ?U =
    of_int (sign p) * setprod (\<lambda>i. ?g i $ p i) ?U + of_int (sign p) * setprod (\<lambda>i. ?h i $ p i) ?U"
    by (simp add: field_simps)
qed rule

lemma det_row_mul:
  fixes a b :: "'n::finite \<Rightarrow> _ ^ 'n"
  shows "det((\<chi> i. if i = k then c *s a i else b i)::'a::comm_ring_1^'n^'n) =
    c * det((\<chi> i. if i = k then a i else b i)::'a::comm_ring_1^'n^'n)"
  unfolding det_def vec_lambda_beta setsum_right_distrib
proof (rule setsum.cong)
  let ?U = "UNIV :: 'n set"
  let ?pU = "{p. p permutes ?U}"
  let ?f = "(\<lambda>i. if i = k then c*s a i else b i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
  let ?g = "(\<lambda> i. if i = k then a i else b i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
  fix p
  assume p: "p \<in> ?pU"
  let ?Uk = "?U - {k}"
  from p have pU: "p permutes ?U"
    by blast
  have kU: "?U = insert k ?Uk"
    by blast
  {
    fix j
    assume j: "j \<in> ?Uk"
    from j have "?f j $ p j = ?g j $ p j"
      by simp
  }
  then have th1: "setprod (\<lambda>i. ?f i $ p i) ?Uk = setprod (\<lambda>i. ?g i $ p i) ?Uk"
    apply -
    apply (rule setprod.cong)
    apply simp_all
    done
  have th3: "finite ?Uk" "k \<notin> ?Uk"
    by auto
  have "setprod (\<lambda>i. ?f i $ p i) ?U = setprod (\<lambda>i. ?f i $ p i) (insert k ?Uk)"
    unfolding kU[symmetric] ..
  also have "\<dots> = ?f k $ p k  * setprod (\<lambda>i. ?f i $ p i) ?Uk"
    apply (rule setprod.insert)
    apply simp
    apply blast
    done
  also have "\<dots> = (c*s a k) $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk"
    by (simp add: field_simps)
  also have "\<dots> = c* (a k $ p k * setprod (\<lambda>i. ?g i $ p i) ?Uk)"
    unfolding th1 by (simp add: ac_simps)
  also have "\<dots> = c* (setprod (\<lambda>i. ?g i $ p i) (insert k ?Uk))"
    unfolding setprod.insert[OF th3] by simp
  finally have "setprod (\<lambda>i. ?f i $ p i) ?U = c* (setprod (\<lambda>i. ?g i $ p i) ?U)"
    unfolding kU[symmetric] .
  then show "of_int (sign p) * setprod (\<lambda>i. ?f i $ p i) ?U =
    c * (of_int (sign p) * setprod (\<lambda>i. ?g i $ p i) ?U)"
    by (simp add: field_simps)
qed rule

lemma det_row_0:
  fixes b :: "'n::finite \<Rightarrow> _ ^ 'n"
  shows "det((\<chi> i. if i = k then 0 else b i)::'a::comm_ring_1^'n^'n) = 0"
  using det_row_mul[of k 0 "\<lambda>i. 1" b]
  apply simp
  apply (simp only: vector_smult_lzero)
  done

lemma det_row_operation:
  fixes A :: "'a::linordered_idom^'n^'n"
  assumes ij: "i \<noteq> j"
  shows "det (\<chi> k. if k = i then row i A + c *s row j A else row k A) = det A"
proof -
  let ?Z = "(\<chi> k. if k = i then row j A else row k A) :: 'a ^'n^'n"
  have th: "row i ?Z = row j ?Z" by (vector row_def)
  have th2: "((\<chi> k. if k = i then row i A else row k A) :: 'a^'n^'n) = A"
    by (vector row_def)
  show ?thesis
    unfolding det_row_add [of i] det_row_mul[of i] det_identical_rows[OF ij th] th2
    by simp
qed

lemma det_row_span:
  fixes A :: "real^'n^'n"
  assumes x: "x \<in> span {row j A |j. j \<noteq> i}"
  shows "det (\<chi> k. if k = i then row i A + x else row k A) = det A"
proof -
  let ?U = "UNIV :: 'n set"
  let ?S = "{row j A |j. j \<noteq> i}"
  let ?d = "\<lambda>x. det (\<chi> k. if k = i then x else row k A)"
  let ?P = "\<lambda>x. ?d (row i A + x) = det A"
  {
    fix k
    have "(if k = i then row i A + 0 else row k A) = row k A"
      by simp
  }
  then have P0: "?P 0"
    apply -
    apply (rule cong[of det, OF refl])
    apply (vector row_def)
    done
  moreover
  {
    fix c z y
    assume zS: "z \<in> ?S" and Py: "?P y"
    from zS obtain j where j: "z = row j A" "i \<noteq> j"
      by blast
    let ?w = "row i A + y"
    have th0: "row i A + (c*s z + y) = ?w + c*s z"
      by vector
    have thz: "?d z = 0"
      apply (rule det_identical_rows[OF j(2)])
      using j
      apply (vector row_def)
      done
    have "?d (row i A + (c*s z + y)) = ?d (?w + c*s z)"
      unfolding th0 ..
    then have "?P (c*s z + y)"
      unfolding thz Py det_row_mul[of i] det_row_add[of i]
      by simp
  }
  ultimately show ?thesis
    apply -
    apply (rule span_induct_alt[of ?P ?S, OF P0, folded scalar_mult_eq_scaleR])
    apply blast
    apply (rule x)
    done
qed

text {*
  May as well do this, though it's a bit unsatisfactory since it ignores
  exact duplicates by considering the rows/columns as a set.
*}

lemma det_dependent_rows:
  fixes A:: "real^'n^'n"
  assumes d: "dependent (rows A)"
  shows "det A = 0"
proof -
  let ?U = "UNIV :: 'n set"
  from d obtain i where i: "row i A \<in> span (rows A - {row i A})"
    unfolding dependent_def rows_def by blast
  {
    fix j k
    assume jk: "j \<noteq> k" and c: "row j A = row k A"
    from det_identical_rows[OF jk c] have ?thesis .
  }
  moreover
  {
    assume H: "\<And> i j. i \<noteq> j \<Longrightarrow> row i A \<noteq> row j A"
    have th0: "- row i A \<in> span {row j A|j. j \<noteq> i}"
      apply (rule span_neg)
      apply (rule set_rev_mp)
      apply (rule i)
      apply (rule span_mono)
      using H i
      apply (auto simp add: rows_def)
      done
    from det_row_span[OF th0]
    have "det A = det (\<chi> k. if k = i then 0 *s 1 else row k A)"
      unfolding right_minus vector_smult_lzero ..
    with det_row_mul[of i "0::real" "\<lambda>i. 1"]
    have "det A = 0" by simp
  }
  ultimately show ?thesis by blast
qed

lemma det_dependent_columns:
  assumes d: "dependent (columns (A::real^'n^'n))"
  shows "det A = 0"
  by (metis d det_dependent_rows rows_transpose det_transpose)

text {* Multilinearity and the multiplication formula. *}

lemma Cart_lambda_cong: "(\<And>x. f x = g x) \<Longrightarrow> (vec_lambda f::'a^'n) = (vec_lambda g :: 'a^'n)"
  by (rule iffD1[OF vec_lambda_unique]) vector

lemma det_linear_row_setsum:
  assumes fS: "finite S"
  shows "det ((\<chi> i. if i = k then setsum (a i) S else c i)::'a::comm_ring_1^'n^'n) =
    setsum (\<lambda>j. det ((\<chi> i. if i = k then a  i j else c i)::'a^'n^'n)) S"
proof (induct rule: finite_induct[OF fS])
  case 1
  then show ?case
    apply simp
    unfolding setsum.empty det_row_0[of k]
    apply rule
    done
next
  case (2 x F)
  then show ?case
    by (simp add: det_row_add cong del: if_weak_cong)
qed

lemma finite_bounded_functions:
  assumes fS: "finite S"
  shows "finite {f. (\<forall>i \<in> {1.. (k::nat)}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1 .. k} \<longrightarrow> f i = i)}"
proof (induct k)
  case 0
  have th: "{f. \<forall>i. f i = i} = {id}"
    by auto
  show ?case
    by (auto simp add: th)
next
  case (Suc k)
  let ?f = "\<lambda>(y::nat,g) i. if i = Suc k then y else g i"
  let ?S = "?f ` (S \<times> {f. (\<forall>i\<in>{1..k}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1..k} \<longrightarrow> f i = i)})"
  have "?S = {f. (\<forall>i\<in>{1.. Suc k}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1.. Suc k} \<longrightarrow> f i = i)}"
    apply (auto simp add: image_iff)
    apply (rule_tac x="x (Suc k)" in bexI)
    apply (rule_tac x = "\<lambda>i. if i = Suc k then i else x i" in exI)
    apply auto
    done
  with finite_imageI[OF finite_cartesian_product[OF fS Suc.hyps(1)], of ?f]
  show ?case
    by metis
qed

lemma eq_id_iff[simp]: "(\<forall>x. f x = x) \<longleftrightarrow> f = id"
  by auto

lemma det_linear_rows_setsum_lemma:
  assumes fS: "finite S"
    and fT: "finite T"
  shows "det ((\<chi> i. if i \<in> T then setsum (a i) S else c i):: 'a::comm_ring_1^'n^'n) =
    setsum (\<lambda>f. det((\<chi> i. if i \<in> T then a i (f i) else c i)::'a^'n^'n))
      {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)}"
  using fT
proof (induct T arbitrary: a c set: finite)
  case empty
  have th0: "\<And>x y. (\<chi> i. if i \<in> {} then x i else y i) = (\<chi> i. y i)"
    by vector
  from empty.prems show ?case
    unfolding th0 by simp
next
  case (insert z T a c)
  let ?F = "\<lambda>T. {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)}"
  let ?h = "\<lambda>(y,g) i. if i = z then y else g i"
  let ?k = "\<lambda>h. (h(z),(\<lambda>i. if i = z then i else h i))"
  let ?s = "\<lambda> k a c f. det((\<chi> i. if i \<in> T then a i (f i) else c i)::'a^'n^'n)"
  let ?c = "\<lambda>j i. if i = z then a i j else c i"
  have thif: "\<And>a b c d. (if a \<or> b then c else d) = (if a then c else if b then c else d)"
    by simp
  have thif2: "\<And>a b c d e. (if a then b else if c then d else e) =
     (if c then (if a then b else d) else (if a then b else e))"
    by simp
  from `z \<notin> T` have nz: "\<And>i. i \<in> T \<Longrightarrow> i = z \<longleftrightarrow> False"
    by auto
  have "det (\<chi> i. if i \<in> insert z T then setsum (a i) S else c i) =
    det (\<chi> i. if i = z then setsum (a i) S else if i \<in> T then setsum (a i) S else c i)"
    unfolding insert_iff thif ..
  also have "\<dots> = (\<Sum>j\<in>S. det (\<chi> i. if i \<in> T then setsum (a i) S else if i = z then a i j else c i))"
    unfolding det_linear_row_setsum[OF fS]
    apply (subst thif2)
    using nz
    apply (simp cong del: if_weak_cong cong add: if_cong)
    done
  finally have tha:
    "det (\<chi> i. if i \<in> insert z T then setsum (a i) S else c i) =
     (\<Sum>(j, f)\<in>S \<times> ?F T. det (\<chi> i. if i \<in> T then a i (f i)
                                else if i = z then a i j
                                else c i))"
    unfolding insert.hyps unfolding setsum.cartesian_product by blast
  show ?case unfolding tha
    using `z \<notin> T`
    by (intro setsum.reindex_bij_witness[where i="?k" and j="?h"])
       (auto intro!: cong[OF refl[of det]] simp: vec_eq_iff)
qed

lemma det_linear_rows_setsum:
  fixes S :: "'n::finite set"
  assumes fS: "finite S"
  shows "det (\<chi> i. setsum (a i) S) =
    setsum (\<lambda>f. det (\<chi> i. a i (f i) :: 'a::comm_ring_1 ^ 'n^'n)) {f. \<forall>i. f i \<in> S}"
proof -
  have th0: "\<And>x y. ((\<chi> i. if i \<in> (UNIV:: 'n set) then x i else y i) :: 'a^'n^'n) = (\<chi> i. x i)"
    by vector
  from det_linear_rows_setsum_lemma[OF fS, of "UNIV :: 'n set" a, unfolded th0, OF finite]
  show ?thesis by simp
qed

lemma matrix_mul_setsum_alt:
  fixes A B :: "'a::comm_ring_1^'n^'n"
  shows "A ** B = (\<chi> i. setsum (\<lambda>k. A$i$k *s B $ k) (UNIV :: 'n set))"
  by (vector matrix_matrix_mult_def setsum_component)

lemma det_mul:
  fixes A B :: "'a::linordered_idom^'n^'n"
  shows "det (A ** B) = det A * det B"
proof -
  let ?U = "UNIV :: 'n set"
  let ?F = "{f. (\<forall>i\<in> ?U. f i \<in> ?U) \<and> (\<forall>i. i \<notin> ?U \<longrightarrow> f i = i)}"
  let ?PU = "{p. p permutes ?U}"
  have fU: "finite ?U"
    by simp
  have fF: "finite ?F"
    by (rule finite)
  {
    fix p
    assume p: "p permutes ?U"
    have "p \<in> ?F" unfolding mem_Collect_eq permutes_in_image[OF p]
      using p[unfolded permutes_def] by simp
  }
  then have PUF: "?PU \<subseteq> ?F" by blast
  {
    fix f
    assume fPU: "f \<in> ?F - ?PU"
    have fUU: "f ` ?U \<subseteq> ?U"
      using fPU by auto
    from fPU have f: "\<forall>i \<in> ?U. f i \<in> ?U" "\<forall>i. i \<notin> ?U \<longrightarrow> f i = i" "\<not>(\<forall>y. \<exists>!x. f x = y)"
      unfolding permutes_def by auto

    let ?A = "(\<chi> i. A$i$f i *s B$f i) :: 'a^'n^'n"
    let ?B = "(\<chi> i. B$f i) :: 'a^'n^'n"
    {
      assume fni: "\<not> inj_on f ?U"
      then obtain i j where ij: "f i = f j" "i \<noteq> j"
        unfolding inj_on_def by blast
      from ij
      have rth: "row i ?B = row j ?B"
        by (vector row_def)
      from det_identical_rows[OF ij(2) rth]
      have "det (\<chi> i. A$i$f i *s B$f i) = 0"
        unfolding det_rows_mul by simp
    }
    moreover
    {
      assume fi: "inj_on f ?U"
      from f fi have fith: "\<And>i j. f i = f j \<Longrightarrow> i = j"
        unfolding inj_on_def by metis
      note fs = fi[unfolded surjective_iff_injective_gen[OF fU fU refl fUU, symmetric]]
      {
        fix y
        from fs f have "\<exists>x. f x = y"
          by blast
        then obtain x where x: "f x = y"
          by blast
        {
          fix z
          assume z: "f z = y"
          from fith x z have "z = x"
            by metis
        }
        with x have "\<exists>!x. f x = y"
          by blast
      }
      with f(3) have "det (\<chi> i. A$i$f i *s B$f i) = 0"
        by blast
    }
    ultimately have "det (\<chi> i. A$i$f i *s B$f i) = 0"
      by blast
  }
  then have zth: "\<forall> f\<in> ?F - ?PU. det (\<chi> i. A$i$f i *s B$f i) = 0"
    by simp
  {
    fix p
    assume pU: "p \<in> ?PU"
    from pU have p: "p permutes ?U"
      by blast
    let ?s = "\<lambda>p. of_int (sign p)"
    let ?f = "\<lambda>q. ?s p * (\<Prod>i\<in> ?U. A $ i $ p i) * (?s q * (\<Prod>i\<in> ?U. B $ i $ q i))"
    have "(setsum (\<lambda>q. ?s q *
        (\<Prod>i\<in> ?U. (\<chi> i. A $ i $ p i *s B $ p i :: 'a^'n^'n) $ i $ q i)) ?PU) =
      (setsum (\<lambda>q. ?s p * (\<Prod>i\<in> ?U. A $ i $ p i) * (?s q * (\<Prod>i\<in> ?U. B $ i $ q i))) ?PU)"
      unfolding sum_permutations_compose_right[OF permutes_inv[OF p], of ?f]
    proof (rule setsum.cong)
      fix q
      assume qU: "q \<in> ?PU"
      then have q: "q permutes ?U"
        by blast
      from p q have pp: "permutation p" and pq: "permutation q"
        unfolding permutation_permutes by auto
      have th00: "of_int (sign p) * of_int (sign p) = (1::'a)"
        "\<And>a. of_int (sign p) * (of_int (sign p) * a) = a"
        unfolding mult.assoc[symmetric]
        unfolding of_int_mult[symmetric]
        by (simp_all add: sign_idempotent)
      have ths: "?s q = ?s p * ?s (q \<circ> inv p)"
        using pp pq permutation_inverse[OF pp] sign_inverse[OF pp]
        by (simp add:  th00 ac_simps sign_idempotent sign_compose)
      have th001: "setprod (\<lambda>i. B$i$ q (inv p i)) ?U = setprod ((\<lambda>i. B$i$ q (inv p i)) \<circ> p) ?U"
        by (rule setprod_permute[OF p])
      have thp: "setprod (\<lambda>i. (\<chi> i. A$i$p i *s B$p i :: 'a^'n^'n) $i $ q i) ?U =
        setprod (\<lambda>i. A$i$p i) ?U * setprod (\<lambda>i. B$i$ q (inv p i)) ?U"
        unfolding th001 setprod.distrib[symmetric] o_def permutes_inverses[OF p]
        apply (rule setprod.cong[OF refl])
        using permutes_in_image[OF q]
        apply vector
        done
      show "?s q * setprod (\<lambda>i. (((\<chi> i. A$i$p i *s B$p i) :: 'a^'n^'n)$i$q i)) ?U =
        ?s p * (setprod (\<lambda>i. A$i$p i) ?U) * (?s (q \<circ> inv p) * setprod (\<lambda>i. B$i$(q \<circ> inv p) i) ?U)"
        using ths thp pp pq permutation_inverse[OF pp] sign_inverse[OF pp]
        by (simp add: sign_nz th00 field_simps sign_idempotent sign_compose)
    qed rule
  }
  then have th2: "setsum (\<lambda>f. det (\<chi> i. A$i$f i *s B$f i)) ?PU = det A * det B"
    unfolding det_def setsum_product
    by (rule setsum.cong [OF refl])
  have "det (A**B) = setsum (\<lambda>f.  det (\<chi> i. A $ i $ f i *s B $ f i)) ?F"
    unfolding matrix_mul_setsum_alt det_linear_rows_setsum[OF fU]
    by simp
  also have "\<dots> = setsum (\<lambda>f. det (\<chi> i. A$i$f i *s B$f i)) ?PU"
    using setsum.mono_neutral_cong_left[OF fF PUF zth, symmetric]
    unfolding det_rows_mul by auto
  finally show ?thesis unfolding th2 .
qed

text {* Relation to invertibility. *}

lemma invertible_left_inverse:
  fixes A :: "real^'n^'n"
  shows "invertible A \<longleftrightarrow> (\<exists>(B::real^'n^'n). B** A = mat 1)"
  by (metis invertible_def matrix_left_right_inverse)

lemma invertible_righ_inverse:
  fixes A :: "real^'n^'n"
  shows "invertible A \<longleftrightarrow> (\<exists>(B::real^'n^'n). A** B = mat 1)"
  by (metis invertible_def matrix_left_right_inverse)

lemma invertible_det_nz:
  fixes A::"real ^'n^'n"
  shows "invertible A \<longleftrightarrow> det A \<noteq> 0"
proof -
  {
    assume "invertible A"
    then obtain B :: "real ^'n^'n" where B: "A ** B = mat 1"
      unfolding invertible_righ_inverse by blast
    then have "det (A ** B) = det (mat 1 :: real ^'n^'n)"
      by simp
    then have "det A \<noteq> 0"
      by (simp add: det_mul det_I) algebra
  }
  moreover
  {
    assume H: "\<not> invertible A"
    let ?U = "UNIV :: 'n set"
    have fU: "finite ?U"
      by simp
    from H obtain c i where c: "setsum (\<lambda>i. c i *s row i A) ?U = 0"
      and iU: "i \<in> ?U"
      and ci: "c i \<noteq> 0"
      unfolding invertible_righ_inverse
      unfolding matrix_right_invertible_independent_rows
      by blast
    have *: "\<And>(a::real^'n) b. a + b = 0 \<Longrightarrow> -a = b"
      apply (drule_tac f="op + (- a)" in cong[OF refl])
      apply (simp only: ab_left_minus add.assoc[symmetric])
      apply simp
      done
    from c ci
    have thr0: "- row i A = setsum (\<lambda>j. (1/ c i) *s (c j *s row j A)) (?U - {i})"
      unfolding setsum.remove[OF fU iU] setsum_cmul
      apply -
      apply (rule vector_mul_lcancel_imp[OF ci])
      apply (auto simp add: field_simps)
      unfolding *
      apply rule
      done
    have thr: "- row i A \<in> span {row j A| j. j \<noteq> i}"
      unfolding thr0
      apply (rule span_setsum)
      apply simp
      apply (rule ballI)
      apply (rule span_mul [where 'a="real^'n", folded scalar_mult_eq_scaleR])+
      apply (rule span_superset)
      apply auto
      done
    let ?B = "(\<chi> k. if k = i then 0 else row k A) :: real ^'n^'n"
    have thrb: "row i ?B = 0" using iU by (vector row_def)
    have "det A = 0"
      unfolding det_row_span[OF thr, symmetric] right_minus
      unfolding det_zero_row[OF thrb] ..
  }
  ultimately show ?thesis
    by blast
qed

text {* Cramer's rule. *}

lemma cramer_lemma_transpose:
  fixes A:: "real^'n^'n"
    and x :: "real^'n"
  shows "det ((\<chi> i. if i = k then setsum (\<lambda>i. x$i *s row i A) (UNIV::'n set)
                             else row i A)::real^'n^'n) = x$k * det A"
  (is "?lhs = ?rhs")
proof -
  let ?U = "UNIV :: 'n set"
  let ?Uk = "?U - {k}"
  have U: "?U = insert k ?Uk"
    by blast
  have fUk: "finite ?Uk"
    by simp
  have kUk: "k \<notin> ?Uk"
    by simp
  have th00: "\<And>k s. x$k *s row k A + s = (x$k - 1) *s row k A + row k A + s"
    by (vector field_simps)
  have th001: "\<And>f k . (\<lambda>x. if x = k then f k else f x) = f"
    by auto
  have "(\<chi> i. row i A) = A" by (vector row_def)
  then have thd1: "det (\<chi> i. row i A) = det A"
    by simp
  have thd0: "det (\<chi> i. if i = k then row k A + (\<Sum>i \<in> ?Uk. x $ i *s row i A) else row i A) = det A"
    apply (rule det_row_span)
    apply (rule span_setsum)
    apply (rule ballI)
    apply (rule span_mul [where 'a="real^'n", folded scalar_mult_eq_scaleR])+
    apply (rule span_superset)
    apply auto
    done
  show "?lhs = x$k * det A"
    apply (subst U)
    unfolding setsum.insert[OF fUk kUk]
    apply (subst th00)
    unfolding add.assoc
    apply (subst det_row_add)
    unfolding thd0
    unfolding det_row_mul
    unfolding th001[of k "\<lambda>i. row i A"]
    unfolding thd1
    apply (simp add: field_simps)
    done
qed

lemma cramer_lemma:
  fixes A :: "real^'n^'n"
  shows "det((\<chi> i j. if j = k then (A *v x)$i else A$i$j):: real^'n^'n) = x$k * det A"
proof -
  let ?U = "UNIV :: 'n set"
  have *: "\<And>c. setsum (\<lambda>i. c i *s row i (transpose A)) ?U = setsum (\<lambda>i. c i *s column i A) ?U"
    by (auto simp add: row_transpose intro: setsum.cong)
  show ?thesis
    unfolding matrix_mult_vsum
    unfolding cramer_lemma_transpose[of k x "transpose A", unfolded det_transpose, symmetric]
    unfolding *[of "\<lambda>i. x$i"]
    apply (subst det_transpose[symmetric])
    apply (rule cong[OF refl[of det]])
    apply (vector transpose_def column_def row_def)
    done
qed

lemma cramer:
  fixes A ::"real^'n^'n"
  assumes d0: "det A \<noteq> 0"
  shows "A *v x = b \<longleftrightarrow> x = (\<chi> k. det(\<chi> i j. if j=k then b$i else A$i$j) / det A)"
proof -
  from d0 obtain B where B: "A ** B = mat 1" "B ** A = mat 1"
    unfolding invertible_det_nz[symmetric] invertible_def
    by blast
  have "(A ** B) *v b = b"
    by (simp add: B matrix_vector_mul_lid)
  then have "A *v (B *v b) = b"
    by (simp add: matrix_vector_mul_assoc)
  then have xe: "\<exists>x. A *v x = b"
    by blast
  {
    fix x
    assume x: "A *v x = b"
    have "x = (\<chi> k. det(\<chi> i j. if j=k then b$i else A$i$j) / det A)"
      unfolding x[symmetric]
      using d0 by (simp add: vec_eq_iff cramer_lemma field_simps)
  }
  with xe show ?thesis
    by auto
qed

text {* Orthogonality of a transformation and matrix. *}

definition "orthogonal_transformation f \<longleftrightarrow> linear f \<and> (\<forall>v w. f v \<bullet> f w = v \<bullet> w)"

lemma orthogonal_transformation:
  "orthogonal_transformation f \<longleftrightarrow> linear f \<and> (\<forall>(v::real ^_). norm (f v) = norm v)"
  unfolding orthogonal_transformation_def
  apply auto
  apply (erule_tac x=v in allE)+
  apply (simp add: norm_eq_sqrt_inner)
  apply (simp add: dot_norm  linear_add[symmetric])
  done

definition "orthogonal_matrix (Q::'a::semiring_1^'n^'n) \<longleftrightarrow>
  transpose Q ** Q = mat 1 \<and> Q ** transpose Q = mat 1"

lemma orthogonal_matrix: "orthogonal_matrix (Q:: real ^'n^'n) \<longleftrightarrow> transpose Q ** Q = mat 1"
  by (metis matrix_left_right_inverse orthogonal_matrix_def)

lemma orthogonal_matrix_id: "orthogonal_matrix (mat 1 :: _^'n^'n)"
  by (simp add: orthogonal_matrix_def transpose_mat matrix_mul_lid)

lemma orthogonal_matrix_mul:
  fixes A :: "real ^'n^'n"
  assumes oA : "orthogonal_matrix A"
    and oB: "orthogonal_matrix B"
  shows "orthogonal_matrix(A ** B)"
  using oA oB
  unfolding orthogonal_matrix matrix_transpose_mul
  apply (subst matrix_mul_assoc)
  apply (subst matrix_mul_assoc[symmetric])
  apply (simp add: matrix_mul_rid)
  done

lemma orthogonal_transformation_matrix:
  fixes f:: "real^'n \<Rightarrow> real^'n"
  shows "orthogonal_transformation f \<longleftrightarrow> linear f \<and> orthogonal_matrix(matrix f)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  let ?mf = "matrix f"
  let ?ot = "orthogonal_transformation f"
  let ?U = "UNIV :: 'n set"
  have fU: "finite ?U" by simp
  let ?m1 = "mat 1 :: real ^'n^'n"
  {
    assume ot: ?ot
    from ot have lf: "linear f" and fd: "\<forall>v w. f v \<bullet> f w = v \<bullet> w"
      unfolding  orthogonal_transformation_def orthogonal_matrix by blast+
    {
      fix i j
      let ?A = "transpose ?mf ** ?mf"
      have th0: "\<And>b (x::'a::comm_ring_1). (if b then 1 else 0)*x = (if b then x else 0)"
        "\<And>b (x::'a::comm_ring_1). x*(if b then 1 else 0) = (if b then x else 0)"
        by simp_all
      from fd[rule_format, of "axis i 1" "axis j 1", unfolded matrix_works[OF lf, symmetric] dot_matrix_vector_mul]
      have "?A$i$j = ?m1 $ i $ j"
        by (simp add: inner_vec_def matrix_matrix_mult_def columnvector_def rowvector_def
            th0 setsum.delta[OF fU] mat_def axis_def)
    }
    then have "orthogonal_matrix ?mf"
      unfolding orthogonal_matrix
      by vector
    with lf have ?rhs
      by blast
  }
  moreover
  {
    assume lf: "linear f" and om: "orthogonal_matrix ?mf"
    from lf om have ?lhs
      unfolding orthogonal_matrix_def norm_eq orthogonal_transformation
      unfolding matrix_works[OF lf, symmetric]
      apply (subst dot_matrix_vector_mul)
      apply (simp add: dot_matrix_product matrix_mul_lid)
      done
  }
  ultimately show ?thesis
    by blast
qed

lemma det_orthogonal_matrix:
  fixes Q:: "'a::linordered_idom^'n^'n"
  assumes oQ: "orthogonal_matrix Q"
  shows "det Q = 1 \<or> det Q = - 1"
proof -
  have th: "\<And>x::'a. x = 1 \<or> x = - 1 \<longleftrightarrow> x*x = 1" (is "\<And>x::'a. ?ths x")
  proof -
    fix x:: 'a
    have th0: "x * x - 1 = (x - 1) * (x + 1)"
      by (simp add: field_simps)
    have th1: "\<And>(x::'a) y. x = - y \<longleftrightarrow> x + y = 0"
      apply (subst eq_iff_diff_eq_0)
      apply simp
      done
    have "x * x = 1 \<longleftrightarrow> x * x - 1 = 0"
      by simp
    also have "\<dots> \<longleftrightarrow> x = 1 \<or> x = - 1"
      unfolding th0 th1 by simp
    finally show "?ths x" ..
  qed
  from oQ have "Q ** transpose Q = mat 1"
    by (metis orthogonal_matrix_def)
  then have "det (Q ** transpose Q) = det (mat 1:: 'a^'n^'n)"
    by simp
  then have "det Q * det Q = 1"
    by (simp add: det_mul det_I det_transpose)
  then show ?thesis unfolding th .
qed

text {* Linearity of scaling, and hence isometry, that preserves origin. *}

lemma scaling_linear:
  fixes f :: "real ^'n \<Rightarrow> real ^'n"
  assumes f0: "f 0 = 0"
    and fd: "\<forall>x y. dist (f x) (f y) = c * dist x y"
  shows "linear f"
proof -
  {
    fix v w
    {
      fix x
      note fd[rule_format, of x 0, unfolded dist_norm f0 diff_0_right]
    }
    note th0 = this
    have "f v \<bullet> f w = c\<^sup>2 * (v \<bullet> w)"
      unfolding dot_norm_neg dist_norm[symmetric]
      unfolding th0 fd[rule_format] by (simp add: power2_eq_square field_simps)}
  note fc = this
  show ?thesis
    unfolding linear_iff vector_eq[where 'a="real^'n"] scalar_mult_eq_scaleR
    by (simp add: inner_add fc field_simps)
qed

lemma isometry_linear:
  "f (0:: real^'n) = (0:: real^'n) \<Longrightarrow> \<forall>x y. dist(f x) (f y) = dist x y \<Longrightarrow> linear f"
  by (rule scaling_linear[where c=1]) simp_all

text {* Hence another formulation of orthogonal transformation. *}

lemma orthogonal_transformation_isometry:
  "orthogonal_transformation f \<longleftrightarrow> f(0::real^'n) = (0::real^'n) \<and> (\<forall>x y. dist(f x) (f y) = dist x y)"
  unfolding orthogonal_transformation
  apply (rule iffI)
  apply clarify
  apply (clarsimp simp add: linear_0 linear_sub[symmetric] dist_norm)
  apply (rule conjI)
  apply (rule isometry_linear)
  apply simp
  apply simp
  apply clarify
  apply (erule_tac x=v in allE)
  apply (erule_tac x=0 in allE)
  apply (simp add: dist_norm)
  done

text {* Can extend an isometry from unit sphere. *}

lemma isometry_sphere_extend:
  fixes f:: "real ^'n \<Rightarrow> real ^'n"
  assumes f1: "\<forall>x. norm x = 1 \<longrightarrow> norm (f x) = 1"
    and fd1: "\<forall> x y. norm x = 1 \<longrightarrow> norm y = 1 \<longrightarrow> dist (f x) (f y) = dist x y"
  shows "\<exists>g. orthogonal_transformation g \<and> (\<forall>x. norm x = 1 \<longrightarrow> g x = f x)"
proof -
  {
    fix x y x' y' x0 y0 x0' y0' :: "real ^'n"
    assume H:
      "x = norm x *\<^sub>R x0"
      "y = norm y *\<^sub>R y0"
      "x' = norm x *\<^sub>R x0'" "y' = norm y *\<^sub>R y0'"
      "norm x0 = 1" "norm x0' = 1" "norm y0 = 1" "norm y0' = 1"
      "norm(x0' - y0') = norm(x0 - y0)"
    then have *: "x0 \<bullet> y0 = x0' \<bullet> y0' + y0' \<bullet> x0' - y0 \<bullet> x0 "
      by (simp add: norm_eq norm_eq_1 inner_add inner_diff)
    have "norm(x' - y') = norm(x - y)"
      apply (subst H(1))
      apply (subst H(2))
      apply (subst H(3))
      apply (subst H(4))
      using H(5-9)
      apply (simp add: norm_eq norm_eq_1)
      apply (simp add: inner_diff scalar_mult_eq_scaleR)
      unfolding *
      apply (simp add: field_simps)
      done
  }
  note th0 = this
  let ?g = "\<lambda>x. if x = 0 then 0 else norm x *\<^sub>R f (inverse (norm x) *\<^sub>R x)"
  {
    fix x:: "real ^'n"
    assume nx: "norm x = 1"
    have "?g x = f x"
      using nx by auto
  }
  then have thfg: "\<forall>x. norm x = 1 \<longrightarrow> ?g x = f x"
    by blast
  have g0: "?g 0 = 0"
    by simp
  {
    fix x y :: "real ^'n"
    {
      assume "x = 0" "y = 0"
      then have "dist (?g x) (?g y) = dist x y"
        by simp
    }
    moreover
    {
      assume "x = 0" "y \<noteq> 0"
      then have "dist (?g x) (?g y) = dist x y"
        apply (simp add: dist_norm)
        apply (rule f1[rule_format])
        apply (simp add: field_simps)
        done
    }
    moreover
    {
      assume "x \<noteq> 0" "y = 0"
      then have "dist (?g x) (?g y) = dist x y"
        apply (simp add: dist_norm)
        apply (rule f1[rule_format])
        apply (simp add: field_simps)
        done
    }
    moreover
    {
      assume z: "x \<noteq> 0" "y \<noteq> 0"
      have th00:
        "x = norm x *\<^sub>R (inverse (norm x) *\<^sub>R x)"
        "y = norm y *\<^sub>R (inverse (norm y) *\<^sub>R y)"
        "norm x *\<^sub>R f ((inverse (norm x) *\<^sub>R x)) = norm x *\<^sub>R f (inverse (norm x) *\<^sub>R x)"
        "norm y *\<^sub>R f (inverse (norm y) *\<^sub>R y) = norm y *\<^sub>R f (inverse (norm y) *\<^sub>R y)"
        "norm (inverse (norm x) *\<^sub>R x) = 1"
        "norm (f (inverse (norm x) *\<^sub>R x)) = 1"
        "norm (inverse (norm y) *\<^sub>R y) = 1"
        "norm (f (inverse (norm y) *\<^sub>R y)) = 1"
        "norm (f (inverse (norm x) *\<^sub>R x) - f (inverse (norm y) *\<^sub>R y)) =
          norm (inverse (norm x) *\<^sub>R x - inverse (norm y) *\<^sub>R y)"
        using z
        by (auto simp add: field_simps intro: f1[rule_format] fd1[rule_format, unfolded dist_norm])
      from z th0[OF th00] have "dist (?g x) (?g y) = dist x y"
        by (simp add: dist_norm)
    }
    ultimately have "dist (?g x) (?g y) = dist x y"
      by blast
  }
  note thd = this
    show ?thesis
    apply (rule exI[where x= ?g])
    unfolding orthogonal_transformation_isometry
    using g0 thfg thd
    apply metis
    done
qed

text {* Rotation, reflection, rotoinversion. *}

definition "rotation_matrix Q \<longleftrightarrow> orthogonal_matrix Q \<and> det Q = 1"
definition "rotoinversion_matrix Q \<longleftrightarrow> orthogonal_matrix Q \<and> det Q = - 1"

lemma orthogonal_rotation_or_rotoinversion:
  fixes Q :: "'a::linordered_idom^'n^'n"
  shows " orthogonal_matrix Q \<longleftrightarrow> rotation_matrix Q \<or> rotoinversion_matrix Q"
  by (metis rotoinversion_matrix_def rotation_matrix_def det_orthogonal_matrix)

text {* Explicit formulas for low dimensions. *}

lemma setprod_neutral_const: "setprod f {(1::nat)..1} = f 1"
  by (fact setprod_singleton_nat_seg)

lemma setprod_2: "setprod f {(1::nat)..2} = f 1 * f 2"
  by (simp add: eval_nat_numeral setprod_numseg mult.commute)

lemma setprod_3: "setprod f {(1::nat)..3} = f 1 * f 2 * f 3"
  by (simp add: eval_nat_numeral setprod_numseg mult.commute)

lemma det_1: "det (A::'a::comm_ring_1^1^1) = A$1$1"
  by (simp add: det_def sign_id)

lemma det_2: "det (A::'a::comm_ring_1^2^2) = A$1$1 * A$2$2 - A$1$2 * A$2$1"
proof -
  have f12: "finite {2::2}" "1 \<notin> {2::2}" by auto
  show ?thesis
    unfolding det_def UNIV_2
    unfolding setsum_over_permutations_insert[OF f12]
    unfolding permutes_sing
    by (simp add: sign_swap_id sign_id swap_id_eq)
qed

lemma det_3:
  "det (A::'a::comm_ring_1^3^3) =
    A$1$1 * A$2$2 * A$3$3 +
    A$1$2 * A$2$3 * A$3$1 +
    A$1$3 * A$2$1 * A$3$2 -
    A$1$1 * A$2$3 * A$3$2 -
    A$1$2 * A$2$1 * A$3$3 -
    A$1$3 * A$2$2 * A$3$1"
proof -
  have f123: "finite {2::3, 3}" "1 \<notin> {2::3, 3}"
    by auto
  have f23: "finite {3::3}" "2 \<notin> {3::3}"
    by auto

  show ?thesis
    unfolding det_def UNIV_3
    unfolding setsum_over_permutations_insert[OF f123]
    unfolding setsum_over_permutations_insert[OF f23]
    unfolding permutes_sing
    by (simp add: sign_swap_id permutation_swap_id sign_compose sign_id swap_id_eq)
qed

end


theory Quantifying_Lists
imports
  Main
begin

fun alls :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
"alls _ Nil = True" |
"alls f (x # xs) = (f x \<and> alls f xs)"

fun exs :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
"exs _ Nil = False" |
"exs f (x # xs) = (f x \<or> exs f xs)"

lemma [simp]: "alls P (xs @ ys) = (alls P xs \<and> alls P ys)"
proof(induct xs)
  case Nil
  then show ?case
    by simp
next
case (Cons a xs)
  then show ?case by simp
qed

lemma "alls P (rev xs) = alls P xs"
proof(induct xs)
case Nil
then show ?case by simp
next
  case (Cons a xs)
  then show ?case by auto
qed

lemma nex_all: "\<not>(\<exists>x. P x) \<equiv> \<forall> x. \<not>P x"
  by simp

(* Disproven by counterexample
lemma "\<exists>P Q xs. exs (\<lambda>x. P x \<and> Q x) xs \<noteq> (exs P xs \<and> exs Q xs)"
proof(rule ccontr)
  assume "\<not>?thesis"
  then have "\<forall>P Q xs. \<not>(exs (\<lambda>x. P x \<and> Q x) xs \<noteq> (exs P xs \<and> exs Q xs))"
    apply(simp only: nex_all) *)

lemma "exs P (map f xs) = exs (P o f) xs"
  by(induct xs, simp+)

lemma [simp]: "exs P (xs @ ys) = (exs P xs \<or> exs P ys)"
  by(induct xs, auto)

lemma "exs P (rev xs) = exs P xs"
proof(induct xs)
case Nil
  then show ?case by simp
next
case (Cons a xs)
  then show ?case by(auto)
qed

lemma "exs (\<lambda>x. P x \<or> Q x) xs = (exs P xs \<or> exs Q xs)"
proof(induct xs)
case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by auto
qed

lemma "exs P xs = (\<not>(\<forall>x\<in>set xs.\<not>(P x)))"
  by(induct xs, auto)

primrec is_in :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_in _ Nil = False" |
"is_in v (Cons x xs) = (if v = x then True else is_in v xs)"

lemma "is_in a xs = exs (\<lambda>x. x = a) xs"
  by(induct xs, auto)

end


(*  Title:      ZF/Nat_ZF.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>The Natural numbers As a Least Fixed Point\<close>

theory Nat_ZF imports OrdQuant Bool begin

definition
  nat :: i  where
    "nat == lfp Inf (%X. {0} \<union> {succ(i). i \<in> X})"

definition
  quasinat :: "i => o"  where
    "quasinat(n) == n=0 | (\<exists>m. n = succ(m))"

definition
  (*Has an unconditional succ case, which is used in "recursor" below.*)
  nat_case :: "[i, i=>i, i]=>i"  where
    "nat_case a b k == THE y. k=0 & y=a | (\<exists>x. k=succ(x) & y=b(x))"

definition
  nat_rec :: "[i, i, [i,i]=>i]=>i"  where
    "nat_rec k a b ==
          wfrec (Memrel nat) k (%n f. nat_case a (%m. b m (f`m)) n)"

  (*Internalized relations on the naturals*)

definition
  Le :: i  where
    "Le == {<x,y>:nat*nat. x \<le> y}"

definition
  Lt :: i  where
    "Lt == {<x, y>:nat*nat. x < y}"

definition
  Ge :: i  where
    "Ge == {<x,y>:nat*nat. y \<le> x}"

definition
  Gt :: i  where
    "Gt == {<x,y>:nat*nat. y < x}"

definition
  greater_than :: "i=>i"  where
    "greater_than(n) == {i \<in> nat. n < i}"

text\<open>No need for a less-than operator: a natural number is its list of
predecessors!\<close>

lemma nat_bnd_mono: "bnd_mono Inf (%X. {0} \<union> {succ(i). i \<in> X})"
apply (rule bnd_monoI)
apply (cut_tac infinity, blast, blast)
done

(* @{term"nat = {0} \<union> {succ(x). x \<in> nat}"} *)
lemmas nat_unfold = nat_bnd_mono [THEN nat_def [THEN def_lfp_unfold]]

(** Type checking of 0 and successor **)

lemma nat_0I [iff,TC]: "0 \<in> nat"
apply (subst nat_unfold)
apply (rule singletonI [THEN UnI1])
done

lemma nat_succI [intro!,TC]: "n \<in> nat ==> succ(n) \<in> nat"
apply (subst nat_unfold)
apply (erule RepFunI [THEN UnI2])
done

lemma nat_1I [iff,TC]: "1 \<in> nat"
by (rule nat_0I [THEN nat_succI])

lemma nat_2I [iff,TC]: "2 \<in> nat"
by (rule nat_1I [THEN nat_succI])

lemma bool_subset_nat: "bool \<subseteq> nat"
by (blast elim!: boolE)

lemmas bool_into_nat = bool_subset_nat [THEN subsetD]

subsection\<open>Injectivity Properties and Induction\<close>

(*Mathematical induction*)
lemma nat_induct [case_names 0 succ, induct set: nat]:
    "[| n \<in> nat;  P(0);  !!x. [| x \<in> nat;  P(x) |] ==> P(succ(x)) |] ==> P(n)"
by (erule def_induct [OF nat_def nat_bnd_mono], blast)

lemma natE:
 assumes "n \<in> nat"
 obtains ("0") "n=0" | (succ) x where "x \<in> nat" "n=succ(x)"
using assms
by (rule nat_unfold [THEN equalityD1, THEN subsetD, THEN UnE]) auto

lemma nat_into_Ord [simp]: "n \<in> nat ==> Ord(n)"
by (erule nat_induct, auto)

(* @{term"i \<in> nat ==> 0 \<le> i"}; same thing as @{term"0<succ(i)"}  *)
lemmas nat_0_le = nat_into_Ord [THEN Ord_0_le]

(* @{term"i \<in> nat ==> i \<le> i"}; same thing as @{term"i<succ(i)"}  *)
lemmas nat_le_refl = nat_into_Ord [THEN le_refl]

lemma Ord_nat [iff]: "Ord(nat)"
apply (rule OrdI)
apply (erule_tac [2] nat_into_Ord [THEN Ord_is_Transset])
apply (unfold Transset_def)
apply (rule ballI)
apply (erule nat_induct, auto)
done

lemma Limit_nat [iff]: "Limit(nat)"
apply (unfold Limit_def)
apply (safe intro!: ltI Ord_nat)
apply (erule ltD)
done

lemma naturals_not_limit: "a \<in> nat ==> ~ Limit(a)"
by (induct a rule: nat_induct, auto)

lemma succ_natD: "succ(i): nat ==> i \<in> nat"
by (rule Ord_trans [OF succI1], auto)

lemma nat_succ_iff [iff]: "succ(n): nat \<longleftrightarrow> n \<in> nat"
by (blast dest!: succ_natD)

lemma nat_le_Limit: "Limit(i) ==> nat \<le> i"
apply (rule subset_imp_le)
apply (simp_all add: Limit_is_Ord)
apply (rule subsetI)
apply (erule nat_induct)
 apply (erule Limit_has_0 [THEN ltD])
apply (blast intro: Limit_has_succ [THEN ltD] ltI Limit_is_Ord)
done

(* [| succ(i): k;  k \<in> nat |] ==> i \<in> k *)
lemmas succ_in_naturalD = Ord_trans [OF succI1 _ nat_into_Ord]

lemma lt_nat_in_nat: "[| m<n;  n \<in> nat |] ==> m \<in> nat"
apply (erule ltE)
apply (erule Ord_trans, assumption, simp)
done

lemma le_in_nat: "[| m \<le> n; n \<in> nat |] ==> m \<in> nat"
by (blast dest!: lt_nat_in_nat)

subsection\<open>Variations on Mathematical Induction\<close>

(*complete induction*)

lemmas complete_induct = Ord_induct [OF _ Ord_nat, case_names less, consumes 1]

lemmas complete_induct_rule =
        complete_induct [rule_format, case_names less, consumes 1]

lemma nat_induct_from_lemma [rule_format]:
    "[| n \<in> nat;  m \<in> nat;
        !!x. [| x \<in> nat;  m \<le> x;  P(x) |] ==> P(succ(x)) |]
     ==> m \<le> n \<longrightarrow> P(m) \<longrightarrow> P(n)"
apply (erule nat_induct)
apply (simp_all add: distrib_simps le0_iff le_succ_iff)
done

(*Induction starting from m rather than 0*)
lemma nat_induct_from:
    "[| m \<le> n;  m \<in> nat;  n \<in> nat;
        P(m);
        !!x. [| x \<in> nat;  m \<le> x;  P(x) |] ==> P(succ(x)) |]
     ==> P(n)"
apply (blast intro: nat_induct_from_lemma)
done

(*Induction suitable for subtraction and less-than*)
lemma diff_induct [case_names 0 0_succ succ_succ, consumes 2]:
    "[| m \<in> nat;  n \<in> nat;
        !!x. x \<in> nat ==> P x 0;
        !!y. y \<in> nat ==> P 0 (succ y);
        !!x y. [| x \<in> nat;  y \<in> nat;  P x y |] ==> P (succ x) (succ y) |]
     ==> P m n"
apply (erule_tac x = m in rev_bspec)
apply (erule nat_induct, simp)
apply (rule ballI)
apply (rename_tac i j)
apply (erule_tac n=j in nat_induct, auto)
done

(** Induction principle analogous to trancl_induct **)

lemma succ_lt_induct_lemma [rule_format]:
     "m \<in> nat ==> P m (succ m) \<longrightarrow> (\<forall>x\<in>nat. P m x \<longrightarrow> P m (succ x)) \<longrightarrow>
                 (\<forall>n\<in>nat. m<n \<longrightarrow> P m n)"
apply (erule nat_induct)
 apply (intro impI, rule nat_induct [THEN ballI])
   prefer 4 apply (intro impI, rule nat_induct [THEN ballI])
apply (auto simp add: le_iff)
done

lemma succ_lt_induct:
    "[| m<n;  n \<in> nat;
        P m (succ m);
        !!x. [| x \<in> nat;  P m x |] ==> P m (succ x) |]
     ==> P m n"
by (blast intro: succ_lt_induct_lemma lt_nat_in_nat)

subsection\<open>quasinat: to allow a case-split rule for @{term nat_case}\<close>

text\<open>True if the argument is zero or any successor\<close>

lemma [iff]: "quasinat(succ(x))"
by (simp add: quasinat_def)

lemma nat_imp_quasinat: "n \<in> nat ==> quasinat(n)"
by (erule natE, simp_all)

lemma non_nat_case: "~ quasinat(x) ==> nat_case a b x = 0"
by (simp add: quasinat_def nat_case_def)

lemma nat_cases_disj: "k=0 | (\<exists>y. k = succ(y)) | ~ quasinat(k)"
apply (case_tac "k=0", simp)
apply (case_tac "\<exists>m. k = succ(m)")
apply (simp_all add: quasinat_def)
done

lemma nat_cases:
     "[|k=0 ==> P;  !!y. k = succ(y) ==> P; ~ quasinat(k) ==> P|] ==> P"
by (insert nat_cases_disj [of k], blast)

(** nat_case **)

lemma nat_case_0 [simp]: "nat_case a b 0 = a"
by (simp add: nat_case_def)

lemma nat_case_succ [simp]: "nat_case a b (succ n) = b(n)"
by (simp add: nat_case_def)

lemma nat_case_type [TC]:
    "[| n \<in> nat;  a \<in> C(0);  !!m. m \<in> nat ==> b(m): C(succ(m)) |]
     ==> nat_case a b n \<in> C(n)"
by (erule nat_induct, auto)

lemma split_nat_case:
  "P(nat_case a b k) \<longleftrightarrow>
   ((k=0 \<longrightarrow> P(a)) & (\<forall>x. k=succ(x) \<longrightarrow> P(b(x))) & (~ quasinat(k) \<longrightarrow> P(0)))"
apply (rule nat_cases [of k])
apply (auto simp add: non_nat_case)
done

subsection\<open>Recursion on the Natural Numbers\<close>

(** nat_rec is used to define eclose and transrec, then becomes obsolete.
    The operator rec, from arith.thy, has fewer typing conditions **)

lemma nat_rec_0: "nat_rec 0 a b = a"
apply (rule nat_rec_def [THEN def_wfrec, THEN trans])
 apply (rule wf_Memrel)
apply (rule nat_case_0)
done

lemma nat_rec_succ: "m \<in> nat ==> nat_rec (succ m) a b = b m (nat_rec m a b)"
apply (rule nat_rec_def [THEN def_wfrec, THEN trans])
 apply (rule wf_Memrel)
apply (simp add: vimage_singleton_iff)
done

(** The union of two natural numbers is a natural number -- their maximum **)

lemma Un_nat_type [TC]: "[| i \<in> nat; j \<in> nat |] ==> i \<union> j \<in> nat"
apply (rule Un_least_lt [THEN ltD])
apply (simp_all add: lt_def)
done

lemma Int_nat_type [TC]: "[| i \<in> nat; j \<in> nat |] ==> i \<inter> j \<in> nat"
apply (rule Int_greatest_lt [THEN ltD])
apply (simp_all add: lt_def)
done

(*needed to simplify unions over nat*)
lemma nat_nonempty [simp]: "nat \<noteq> 0"
by blast

text\<open>A natural number is the set of its predecessors\<close>
lemma nat_eq_Collect_lt: "i \<in> nat ==> {j\<in>nat. j<i} = i"
apply (rule equalityI)
apply (blast dest: ltD)
apply (auto simp add: Ord_mem_iff_lt)
apply (blast intro: lt_trans)
done

lemma Le_iff [iff]: "<x,y> \<in> Le \<longleftrightarrow> x \<le> y & x \<in> nat & y \<in> nat"
by (force simp add: Le_def)

end


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

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

datatype Nat = Z | S "Nat"

fun y :: "'a list => 'a list => 'a list" where
"y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

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

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

theorem property0 :
  "((~ (x n m)) ==>
      ((count n (y xs (cons2 m (nil2)))) = (count n xs)))"
  oops

end


theory Memory_Allocation_Model
imports Main
begin

subsection \<open>def of datetype\<close>
(*------------------------------------------------------------------------------------------------*)
datatype (set: 'a) tree = leaf: Leaf (L: 'a) |
                          node: Node (LL:"'a tree") (LR:"'a tree") (RL:"'a tree") (RR:"'a tree")
                        for map: tree_map

datatype block_state_type = FREE | ALLOC
type_synonym ID = nat
type_synonym Block = "(block_state_type \<times> ID) tree"

type_synonym poolname = "string"
record Pool = zerolevelblocks :: "Block set"
              pname :: poolname

subsection \<open>def of 'a tree function\<close>
(*------------------------------------------------------------------------------------------------*)
definition compare2 :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "compare2 a b \<equiv> (if a > b then a else b)"

definition compare4 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
  where "compare4 a b c d \<equiv> (let c1 = compare2 a b;
                                 c2 = compare2 c1 c in compare2 c2 d)"

fun get_level' :: "'a tree \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat"
  where "get_level' (Leaf x) b n = (if (x = b) then n else 0)" |
        "get_level' (Node n1 n2 n3 n4) b n = compare4 (get_level' n1 b (Suc n))
                                                      (get_level' n2 b (Suc n))
                                                      (get_level' n3 b (Suc n))
                                                      (get_level' n4 b (Suc n))"

definition get_level :: "'a tree \<Rightarrow> 'a \<Rightarrow> nat"
  where "get_level B b \<equiv> get_level' B b 0"

lemma level_notbelong:
  "b \<notin> set B \<Longrightarrow>
  get_level' B b lv = 0"
proof(induct B arbitrary: lv)
case (Leaf x)
  then show ?case by auto
next
  case (Node B1 B2 B3 B4)
  have b1: "b \<notin> set B1"
    using Node.prems by auto
  have b2: "b \<notin> set B2"
    using Node.prems by auto
  have b3: "b \<notin> set B3"
    using Node.prems by auto
  have b4: "b \<notin> set B4"
    using Node.prems by auto
  have l_node': "get_level' (Node B1 B2 B3 B4) b lv =
                compare4 (get_level' B1 b (Suc lv))
                         (get_level' B2 b (Suc lv))
                         (get_level' B3 b (Suc lv))
                         (get_level' B4 b (Suc lv))"
    using get_level'.simps(2) by auto
  have l1: "get_level' B1 b (Suc lv) = 0"
    using Node.hyps(1) b1 by auto
  have l2: "get_level' B2 b (Suc lv) = 0"
    using Node.hyps(2) b2 by auto
  have l3: "get_level' B3 b (Suc lv) = 0"
    using Node.hyps(3) b3 by auto
  have l4: "get_level' B4 b (Suc lv) = 0"
    using Node.hyps(4) b4 by auto
  have l_node: "compare4 (get_level' B1 b (Suc lv))
                         (get_level' B2 b (Suc lv))
                         (get_level' B3 b (Suc lv))
                         (get_level' B4 b (Suc lv)) = 0"
    unfolding compare4_def Let_def compare2_def l1 l2 l3 l4 by auto
  show ?case using l_node' l_node by auto
qed

fun get_level_node' :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> nat \<Rightarrow> nat"
  where "get_level_node' (Leaf x) b n = (if leaf b \<and> (L b) = x then n else 0)" |
        "get_level_node' (Node n1 n2 n3 n4) b n = (if (Node n1 n2 n3 n4) = b then n
                                                  else compare4 (get_level_node' n1 b (Suc n))
                                                                (get_level_node' n2 b (Suc n))
                                                                (get_level_node' n3 b (Suc n))
                                                                (get_level_node' n4 b (Suc n)))"

definition get_level_node :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> nat"
  where "get_level_node B b \<equiv> get_level_node' B b 0"

lemma level_node_notbelong:
  "leaf b \<Longrightarrow>
  L b \<notin> set B \<Longrightarrow>
  get_level_node' B b lv = 0"
proof(induct B arbitrary: lv)
case (Leaf x)
  then show ?case by auto
next
  case (Node B1 B2 B3 B4)
  have b1: "L b \<notin> set B1"
    using Node.prems by auto
  have b2: "L b \<notin> set B2"
    using Node.prems by auto
  have b3: "L b \<notin> set B3"
    using Node.prems by auto
  have b4: "L b \<notin> set B4"
    using Node.prems by auto
  have node_not_l: "Node B1 B2 B3 B4 \<noteq> b"
    using Node.prems(1) by auto
  have l_node': "get_level_node' (Node B1 B2 B3 B4) b lv =
                compare4 (get_level_node' B1 b (Suc lv))
                         (get_level_node' B2 b (Suc lv))
                         (get_level_node' B3 b (Suc lv))
                         (get_level_node' B4 b (Suc lv))"
    using get_level_node'.simps(2) node_not_l by auto
  have l1: "get_level_node' B1 b (Suc lv) = 0"
    using Node.hyps(1) Node.prems(1) b1 by auto
  have l2: "get_level_node' B2 b (Suc lv) = 0"
    using Node.hyps(2) Node.prems(1) b2 by auto
  have l3: "get_level_node' B3 b (Suc lv) = 0"
    using Node.hyps(3) Node.prems(1) b3 by auto
  have l4: "get_level_node' B4 b (Suc lv) = 0"
    using Node.hyps(4) Node.prems(1) b4 by auto
  have l_node: "compare4 (get_level_node' B1 b (Suc lv))
                         (get_level_node' B2 b (Suc lv))
                         (get_level_node' B3 b (Suc lv))
                         (get_level_node' B4 b (Suc lv)) = 0"
    unfolding compare4_def Let_def compare2_def using l1 l2 l3 l4 by auto
  show ?case using l_node' l_node by auto
qed

lemma level_node_notbelong2:
  "node b \<Longrightarrow>
  \<not> tree.set b \<subseteq> tree.set B \<Longrightarrow>
  get_level_node' B b lv = 0"
proof(induct B arbitrary: lv)
  case (Leaf x)
  show ?case using Leaf.prems(1) by auto
next
  case (Node B1 B2 B3 B4)
  have not_eq: "b \<noteq> Node B1 B2 B3 B4"
    using Node.prems(2) by blast
  have b1: "\<not> tree.set b \<subseteq> tree.set B1"
    using Node.prems(2) dual_order.trans by auto
  have b2: "\<not> tree.set b \<subseteq> tree.set B2"
    using Node.prems(2) dual_order.trans by auto
  have b3: "\<not> tree.set b \<subseteq> tree.set B3"
    using Node.prems(2) dual_order.trans by auto
  have b4: "\<not> tree.set b \<subseteq> tree.set B4"
    using Node.prems(2) dual_order.trans by auto
  have l1: "get_level_node' B1 b (Suc lv) = 0"
    using Node.hyps(1) Node.prems(1) b1 by auto
  have l2: "get_level_node' B2 b (Suc lv) = 0"
    using Node.hyps(2) Node.prems(1) b2 by auto
  have l3: "get_level_node' B3 b (Suc lv) = 0"
    using Node.hyps(3) Node.prems(1) b3 by auto
  have l4: "get_level_node' B4 b (Suc lv) = 0"
    using Node.hyps(4) Node.prems(1) b4 by auto
  have l_node': "get_level_node' (Node B1 B2 B3 B4) b lv =
                compare4 (get_level_node' B1 b (Suc lv))
                         (get_level_node' B2 b (Suc lv))
                         (get_level_node' B3 b (Suc lv))
                         (get_level_node' B4 b (Suc lv))"
    using get_level_node'.simps(2) not_eq by auto
  have l_node: "compare4 (get_level_node' B1 b (Suc lv))
                         (get_level_node' B2 b (Suc lv))
                         (get_level_node' B3 b (Suc lv))
                         (get_level_node' B4 b (Suc lv)) = 0"
    unfolding compare4_def Let_def compare2_def using l1 l2 l3 l4 by auto
  then show ?case using l_node' l_node by auto
qed

subsection \<open>def of function_call\<close>
(*------------------------------------------------------------------------------------------------*)
definition getnewid :: "ID set \<Rightarrow> (ID \<times> ID \<times> ID \<times> ID \<times> ID set)"
  where "getnewid ids \<equiv> let nid1 = SOME p1. p1 \<notin> ids;
                            ids1 = ids \<union> {nid1};
                            nid2 = SOME p2. p2 \<notin> ids1;
                            ids2 = ids1 \<union> {nid2};
                            nid3 = SOME p3. p3 \<notin> ids2;
                            ids3 = ids2 \<union> {nid3};
                            nid4 = SOME p4. p4 \<notin> ids3;
                            ids4 = ids3 \<union> {nid4} in
                        (nid1, nid2, nid3, nid4, ids4)"

lemma getnewid_inc: "ids \<subseteq> snd(snd(snd(snd(getnewid ids))))"
  unfolding getnewid_def Let_def by auto

lemma newid1_in_getnewid: "fst(getnewid ids) \<in> snd(snd(snd(snd(getnewid ids))))"
  unfolding getnewid_def Let_def by auto

lemma newid2_in_getnewid: "fst(snd(getnewid ids)) \<in> snd(snd(snd(snd(getnewid ids))))"
  unfolding getnewid_def Let_def by auto

lemma newid3_in_getnewid: "fst(snd(snd(getnewid ids))) \<in> snd(snd(snd(snd(getnewid ids))))"
  unfolding getnewid_def Let_def by auto

lemma newid4_in_getnewid: "fst(snd(snd(snd(getnewid ids)))) \<in> snd(snd(snd(snd(getnewid ids))))"
  unfolding getnewid_def Let_def by auto

lemma exists_p_getnewid:
  "\<exists>xa xb xc xd. getnewid ids = (xa, xb, xc, xd, ids \<union> {xa, xb, xc, xd})"
  unfolding getnewid_def Let_def by auto

lemma getnewid_diffab:
  "finite ids \<Longrightarrow>
  newid = getnewid ids \<Longrightarrow>
  xa = fst newid \<Longrightarrow>
  xb = fst (snd newid) \<Longrightarrow>
  xc = fst (snd (snd newid)) \<Longrightarrow>
  xd = fst (snd (snd (snd newid))) \<Longrightarrow>
  xa \<noteq> xb"
  unfolding getnewid_def Let_def
  apply auto
  by (metis (mono_tags, lifting) add.left_neutral finite_nat_set_iff_bounded lessI not_add_less2 plus_nat.simps(2) someI_ex)

lemma getnewid_diffac:
  "finite ids \<Longrightarrow>
  newid = getnewid ids \<Longrightarrow>
  xa = fst newid \<Longrightarrow>
  xb = fst (snd newid) \<Longrightarrow>
  xc = fst (snd (snd newid)) \<Longrightarrow>
  xd = fst (snd (snd (snd newid))) \<Longrightarrow>
  xa \<noteq> xc"
  unfolding getnewid_def Let_def
  apply auto
  by (smt ex_new_if_finite finite.insertI infinite_UNIV_nat insertCI some_eq_ex someI_ex)

lemma getnewid_diffad:
  "finite ids \<Longrightarrow>
  newid = getnewid ids \<Longrightarrow>
  xa = fst newid \<Longrightarrow>
  xb = fst (snd newid) \<Longrightarrow>
  xc = fst (snd (snd newid)) \<Longrightarrow>
  xd = fst (snd (snd (snd newid))) \<Longrightarrow>
  xa \<noteq> xd"
  unfolding getnewid_def Let_def
  apply auto
  by (smt ex_new_if_finite finite.insertI infinite_UNIV_nat insertCI some_eq_ex someI_ex)

lemma getnewid_diffbc:
  "finite ids \<Longrightarrow>
  newid = getnewid ids \<Longrightarrow>
  xa = fst newid \<Longrightarrow>
  xb = fst (snd newid) \<Longrightarrow>
  xc = fst (snd (snd newid)) \<Longrightarrow>
  xd = fst (snd (snd (snd newid))) \<Longrightarrow>
  xb \<noteq> xc"
  unfolding getnewid_def Let_def
  apply auto
  by (smt ex_new_if_finite finite.insertI infinite_UNIV_nat insertCI some_eq_ex someI_ex)

lemma getnewid_diffbd:
  "finite ids \<Longrightarrow>
  newid = getnewid ids \<Longrightarrow>
  xa = fst newid \<Longrightarrow>
  xb = fst (snd newid) \<Longrightarrow>
  xc = fst (snd (snd newid)) \<Longrightarrow>
  xd = fst (snd (snd (snd newid))) \<Longrightarrow>
  xb \<noteq> xd"
  unfolding getnewid_def Let_def
  apply auto
  by (smt ex_new_if_finite finite.insertI infinite_UNIV_nat insertCI some_eq_ex someI_ex)

lemma getnewid_diffcd:
  "finite ids \<Longrightarrow>
  newid = getnewid ids \<Longrightarrow>
  xa = fst newid \<Longrightarrow>
  xb = fst (snd newid) \<Longrightarrow>
  xc = fst (snd (snd newid)) \<Longrightarrow>
  xd = fst (snd (snd (snd newid))) \<Longrightarrow>
  xc \<noteq> xd"
  unfolding getnewid_def Let_def
  apply auto
  by (smt ex_new_if_finite finite.insertI infinite_UNIV_nat insertCI some_eq_ex someI_ex)

lemma getnewid_diff1:
  "finite ids \<Longrightarrow>
  xa = fst (getnewid ids) \<Longrightarrow>
  xb = fst (snd (getnewid ids)) \<Longrightarrow>
  xc = fst (snd (snd (getnewid ids))) \<Longrightarrow>
  xd = fst (snd (snd (snd (getnewid ids)))) \<Longrightarrow>
  xa \<noteq> xb \<and> xa \<noteq> xc \<and> xa \<noteq> xd"
  by (meson getnewid_diffab getnewid_diffac getnewid_diffad)

lemma getnewid_diff2:
  "finite ids \<Longrightarrow>
  xa = fst (getnewid ids) \<Longrightarrow>
  xb = fst (snd (getnewid ids)) \<Longrightarrow>
  xc = fst (snd (snd (getnewid ids))) \<Longrightarrow>
  xd = fst (snd (snd (snd (getnewid ids)))) \<Longrightarrow>
  xb \<noteq> xc \<and> xb \<noteq> xd \<and> xc \<noteq> xd"
  by (meson getnewid_diffbc getnewid_diffbd getnewid_diffcd)

lemma getnewid_anot:
  "finite ids \<Longrightarrow>
  newid = getnewid ids \<Longrightarrow>
  xa = fst newid \<Longrightarrow>
  xb = fst (snd newid) \<Longrightarrow>
  xc = fst (snd (snd newid)) \<Longrightarrow>
  xd = fst (snd (snd (snd newid))) \<Longrightarrow>
  xa \<notin> ids"
  unfolding getnewid_def Let_def
  apply auto
  by (metis Collect_mem_eq finite_Collect_not infinite_UNIV_nat not_finite_existsD someI_ex)

lemma getnewid_bnot:
  "finite ids \<Longrightarrow>
  newid = getnewid ids \<Longrightarrow>
  xa = fst newid \<Longrightarrow>
  xb = fst (snd newid) \<Longrightarrow>
  xc = fst (snd (snd newid)) \<Longrightarrow>
  xd = fst (snd (snd (snd newid))) \<Longrightarrow>
  xb \<notin> ids"
  unfolding getnewid_def Let_def
  apply auto
  by (metis (mono_tags, lifting) finite_nat_set_iff_bounded lessI less_irrefl not_add_less2 plus_nat.simps(2) someI_ex)

lemma getnewid_cnot:
  "finite ids \<Longrightarrow>
  newid = getnewid ids \<Longrightarrow>
  xa = fst newid \<Longrightarrow>
  xb = fst (snd newid) \<Longrightarrow>
  xc = fst (snd (snd newid)) \<Longrightarrow>
  xd = fst (snd (snd (snd newid))) \<Longrightarrow>
  xc \<notin> ids"
  unfolding getnewid_def Let_def
  apply auto
  by (smt finite.insertI finite_nat_set_iff_bounded insert_compr less_irrefl mem_Collect_eq someI_ex)

lemma getnewid_dnot:
  "finite ids \<Longrightarrow>
  newid = getnewid ids \<Longrightarrow>
  xa = fst newid \<Longrightarrow>
  xb = fst (snd newid) \<Longrightarrow>
  xc = fst (snd (snd newid)) \<Longrightarrow>
  xd = fst (snd (snd (snd newid))) \<Longrightarrow>
  xd \<notin> ids"
  unfolding getnewid_def Let_def
  apply auto
  by (smt ball_empty empty_Collect_eq ex_new_if_finite finite.insertI infinite_UNIV_nat insert_compr mem_Collect_eq some_eq_ex)

lemma getnewid_notbelong:
  "finite ids \<Longrightarrow>
  xa = fst (getnewid ids) \<Longrightarrow>
  xb = fst (snd (getnewid ids)) \<Longrightarrow>
  xc = fst (snd (snd (getnewid ids))) \<Longrightarrow>
  xd = fst (snd (snd (snd (getnewid ids)))) \<Longrightarrow>
  xa \<notin> ids \<and> xb \<notin> ids \<and> xc \<notin> ids \<and> xd \<notin> ids"
  by (simp add: getnewid_anot getnewid_bnot getnewid_cnot getnewid_dnot)

definition divide :: "Block \<Rightarrow> ID set \<Rightarrow> (Block \<times> ID set)"
  where "divide bl ids \<equiv>
         (let b = L bl;
              nids = getnewid ids;
              x1 = fst nids;
              x2 = fst (snd nids);
              x3 = fst (snd (snd nids));
              x4 = fst (snd (snd (snd nids)));
              newids = snd (snd (snd (snd nids))) in
         (Node (Leaf (ALLOC, x1)) (Leaf (FREE, x2)) (Leaf (FREE, x3)) (Leaf (FREE, x4)), newids))"

lemma divide_diff:
  "finite ids \<Longrightarrow>
  fst (divide b ids) = Node (Leaf ll) (Leaf lr) (Leaf rl) (Leaf rr) \<Longrightarrow>
  snd ll \<noteq> snd lr \<and> snd ll \<noteq> snd rl \<and> snd ll \<noteq> snd rr"
  unfolding divide_def Let_def using getnewid_diff1 by auto

lemma divide_diff2:
  "finite ids \<Longrightarrow>
  fst (divide b ids) = Node (Leaf ll) (Leaf lr) (Leaf rl) (Leaf rr) \<Longrightarrow>
  snd lr \<noteq> snd rl \<and> snd lr \<noteq> snd rr \<and> snd rl \<noteq> snd rr"
  unfolding divide_def Let_def using getnewid_diff2 by auto

lemma divide_belong:
  "fst (divide b ids) = Node (Leaf ll) (Leaf lr) (Leaf rl) (Leaf rr) \<Longrightarrow>
  snd ll \<in> snd (divide b ids) \<and>
  snd lr \<in> snd (divide b ids) \<and>
  snd rl \<in> snd (divide b ids) \<and>
  snd rr \<in> snd (divide b ids)"
  unfolding divide_def Let_def
  using newid1_in_getnewid newid2_in_getnewid newid3_in_getnewid newid4_in_getnewid by auto

lemma divide_notbelong:
  "finite ids \<Longrightarrow>
  fst (divide b ids) = Node (Leaf ll) (Leaf lr) (Leaf rl) (Leaf rr) \<Longrightarrow>
  snd ll \<notin> ids \<and> snd lr \<notin> ids \<and> snd rl \<notin> ids \<and> snd rr \<notin> ids"
  unfolding divide_def Let_def using getnewid_notbelong by auto

lemma divide_finite:
  "finite ids \<Longrightarrow>
  finite (snd (divide b ids))"
proof-
  assume a0: "finite ids"
  have p0: "snd (divide b ids) = snd (snd (snd (snd (getnewid ids))))"
    unfolding divide_def Let_def by auto
  obtain xa xb xc xd
    where obtain_divide: "snd (divide b ids) = ids \<union> {xa, xb, xc, xd}"
    using p0 exists_p_getnewid by (metis sndI)
  have "finite (ids \<union> {xa, xb, xc, xd})" using a0 by auto
  then show ?thesis using obtain_divide by auto
qed

definition getnewid2 :: "ID set \<Rightarrow> (ID \<times> ID set)"
  where "getnewid2 ids \<equiv> let nid = SOME p. p \<notin> ids;
                             nids = ids \<union> {nid} in
                             (nid, nids)"

lemma getnewid2_inc: "ids \<subseteq> snd(getnewid2 ids)"
  unfolding getnewid2_def Let_def by auto

lemma newid_in_getnewid2: "fst(getnewid2 ids) \<in> snd(getnewid2 ids)"
  unfolding getnewid2_def Let_def by auto

lemma exists_p_getnewid2: "\<exists>p. getnewid2 ids = (p, ids \<union> {p})"
  unfolding getnewid2_def by metis

lemma getnewid2_anot:
  "finite ids \<Longrightarrow>
  xa = fst (getnewid2 ids) \<Longrightarrow>
  xa \<notin> ids"
  unfolding getnewid2_def Let_def
  apply auto
  by (metis Collect_mem_eq finite_Collect_not infinite_UNIV_char_0 not_finite_existsD someI_ex)

definition combine :: "Block \<Rightarrow> ID set \<Rightarrow> (Block \<times> ID set)"
  where "combine b ids \<equiv> (if (\<exists>a1 a2 a3 a4. b = Node (Leaf (FREE, a1)) (Leaf (FREE, a2)) (Leaf (FREE, a3)) (Leaf (FREE, a4))) then
                              let nids = getnewid2 ids;
                                  newid = fst nids;
                                  newids = snd nids in (Leaf (FREE, newid), newids)
                           else (b, ids))"

lemma combine_ids:
  "ids \<subseteq> snd (combine b ids)"
  unfolding combine_def Let_def
  using getnewid2_inc by auto

lemma combine_finite:
  "finite ids \<Longrightarrow>
  finite (snd (combine b ids))"
  unfolding combine_def Let_def apply auto
  using exists_p_getnewid2 snd_conv
  by (metis Un_insert_right finite_insert sup_bot.right_neutral)

definition freesets :: "Block \<Rightarrow> Block set"
  where "freesets b = {l. leaf l \<and> L l \<in> set b \<and> fst (L l) = FREE}"

definition freesets_level :: "Block \<Rightarrow> nat \<Rightarrow> Block set"
  where "freesets_level b lv = {l. l \<in> freesets b \<and> get_level b (L l) = lv}"

definition freesets_level_pool :: "Block set \<Rightarrow> nat \<Rightarrow> Block set"
  where "freesets_level_pool bset lv = {l. \<exists>b \<in> bset. l \<in> freesets_level b lv}"

definition freesets_maxlevel :: "Block set \<Rightarrow> nat \<Rightarrow> nat"
  where "freesets_maxlevel bset lv \<equiv>
          THE lmax. lmax \<le> lv \<and>
                    freesets_level_pool bset lmax \<noteq> {} \<and>
                    (\<forall>l. l \<le> lv \<and> freesets_level_pool bset l \<noteq> {} \<longrightarrow> l \<le> lmax)"

definition exists_freelevel :: "Block set \<Rightarrow> nat \<Rightarrow> bool"
  where "exists_freelevel bset lv \<equiv> \<exists>lv'. lv' \<le> lv \<and> freesets_level_pool bset lv' \<noteq> {}"

lemma exist_lmax_h:
  "freesets_level_pool bset lv = {} \<Longrightarrow>
  \<exists>lv'. lv' < lv \<and> freesets_level_pool bset lv' \<noteq> {} \<Longrightarrow>
  \<exists>lmax. lmax < lv \<and>
         freesets_level_pool bset lmax \<noteq> {} \<and>
         (\<forall>l. l \<le> lv \<and> l > lmax \<longrightarrow> freesets_level_pool bset l = {})"
proof(induct lv)
  case 0
  then show ?case by auto
next
  case (Suc xa)
  then show ?case
    by (smt Suc_leI Suc_le_lessD le_Suc_eq lessI not_less)
qed

lemma exist_lmax:
  "exists_freelevel bset lv \<Longrightarrow>
  \<exists>!lmax. lmax \<le> lv \<and>
          freesets_level_pool bset lmax \<noteq> {} \<and>
          (\<forall>l. l \<le> lv \<and> freesets_level_pool bset l \<noteq> {} \<longrightarrow> l \<le> lmax)"
proof-
  assume exi_level: "exists_freelevel bset lv"
  hence exi_level_def: "\<exists>lv'. lv' \<le> lv \<and> freesets_level_pool bset lv' \<noteq> {}"
    unfolding exists_freelevel_def by auto
  {assume a0: "freesets_level_pool bset lv \<noteq> {}"
    hence "lv \<le> lv \<and>
          freesets_level_pool bset lv \<noteq> {} \<and>
          (\<forall>l. l \<le> lv \<and> freesets_level_pool bset l \<noteq> {} \<longrightarrow> l \<le> lv)"
      using exi_level_def by auto
    then have ?thesis using le_antisym by blast
  }moreover
  {assume a1: "freesets_level_pool bset lv = {}"
    hence exi_level_less: "\<exists>lv'. lv' < lv \<and> freesets_level_pool bset lv' \<noteq> {}"
      using exi_level_def le_neq_implies_less by blast
    have "\<exists>lmax. lmax < lv \<and>
                 freesets_level_pool bset lmax \<noteq> {} \<and>
                 (\<forall>l. l \<le> lv \<and> l > lmax \<longrightarrow> freesets_level_pool bset l = {})"
      using exist_lmax_h a1 exi_level_less by auto
    then obtain lmax where exi_lmax:
      "lmax < lv \<and>
      freesets_level_pool bset lmax \<noteq> {} \<and>
      (\<forall>l. l \<le> lv \<and> l > lmax \<longrightarrow> freesets_level_pool bset l = {})" by auto
    then have "\<forall>l. l \<le> lv \<and> freesets_level_pool bset l \<noteq> {} \<longrightarrow> l \<le> lmax"
      using a1 by (metis le_less_linear)
    then have ?thesis using exi_lmax
      by (meson le_less_Suc_eq le_simps(2) less_imp_le_nat)
  }
  ultimately have ?thesis by linarith
  then show ?thesis by auto
qed

subsection \<open>def of sub core function\<close>
(*------------------------------------------------------------------------------------------------*)
definition set_state_type :: "Block \<Rightarrow> block_state_type \<Rightarrow> Block"
  where "set_state_type bl t \<equiv> (let b = (L bl) in Leaf (t, snd b))"

definition replace :: "Block \<Rightarrow> Block \<Rightarrow> Block \<Rightarrow> Block"
  where "replace B b b' \<equiv> (tree_map (\<lambda>b1. if (b1 = L b) then (L b') else b1) B)"

lemma no_replace:
  "L b \<notin> set blo \<Longrightarrow>
  b' = set_state_type b t \<Longrightarrow>
  tree_map (\<lambda>b1. if b1 = L b then L b' else b1) blo = blo"
  by (smt tree.map_cong0 tree.map_ident)

fun split :: "Block \<Rightarrow> ID set \<Rightarrow> nat \<Rightarrow> (Block \<times> ID set \<times> ID)"
  where "split b ids lv = (if lv = 0 then (b, ids, snd (L b))
                          else
                            let re = divide b ids;
                                node = fst re;
                                newids = snd re;
                                c1 = split (LL node) newids (lv - 1) in
                                (Node (fst c1) (LR node) (RL node) (RR node), fst (snd c1), snd (snd c1)))"

lemma split_induct:
  "lv > 0 \<Longrightarrow>
  fst (divide b ids) = Node (Leaf ll) (Leaf lr) (Leaf rl) (Leaf rr) \<Longrightarrow>
  newids = snd (divide b ids) \<Longrightarrow>
  fst (split b ids lv) = Node (fst (split (Leaf ll) newids (lv - 1))) (Leaf lr) (Leaf rl) (Leaf rr)"
  using split.simps unfolding Let_def
  by (metis fst_conv less_not_refl3 tree.sel(2) tree.sel(3) tree.sel(4) tree.sel(5))

fun replace_leaf :: "Block \<Rightarrow> Block \<Rightarrow> Block \<Rightarrow> Block"
  where "replace_leaf (Leaf x) y st = (if (x = (L y)) then st else (Leaf x))" |
        "replace_leaf (Node n1 n2 n3 n4) y st = Node (replace_leaf n1 y st)
                                                     (replace_leaf n2 y st)
                                                     (replace_leaf n3 y st)
                                                     (replace_leaf n4 y st)"

lemma no_replace_leaf:
  "(L b) \<notin> set B \<Longrightarrow>
  replace_leaf B b subbtr = B"
  apply(induct B)
  by auto

lemma replace_leaf_belong:
  "(L b) \<in> set B \<Longrightarrow>
  (L l) \<in> set subbtr \<Longrightarrow>
  (L l) \<in> set (replace_leaf B b subbtr)"
  apply(induct B)
  by auto

lemma replace_subbtr_belong:
  "(L b) \<in> set B \<Longrightarrow>
  tree.set subbtr \<subseteq> tree.set (replace_leaf B b subbtr)"
  apply(induct B)
  by auto

fun merge :: "Block \<Rightarrow> ID set \<Rightarrow> (Block \<times> ID set)"
  where "merge (Leaf v) ids = ((Leaf v), ids)" |
        "merge (Node ll lr rl rr) ids =
                (if (\<exists>xa xb xc xd. (Node ll lr rl rr) = Node (Leaf (FREE, xa))
                                                             (Leaf (FREE, xb))
                                                             (Leaf (FREE, xc))
                                                             (Leaf (FREE, xd)))
                 then combine (Node ll lr rl rr) ids
                 else
                    let m1 = merge ll ids;
                        m2 = merge lr (snd m1);
                        m3 = merge rl (snd m2);
                        m4 = merge rr (snd m3) in
                    combine (Node (fst m1) (fst m2) (fst m3) (fst m4)) (snd m4))"

definition alloc1 :: "Block set \<Rightarrow> nat \<Rightarrow> ID set \<Rightarrow> (Block set \<times> ID set \<times> bool \<times> ID set)"
  where "alloc1 bset lv ids \<equiv> (let blo = (SOME b. b \<in> bset \<and> freesets_level b lv \<noteq> {});
                                   b = (SOME l. l \<in> freesets_level blo lv);
                                   allocid = snd (L b);
                                   newblo = replace blo b (set_state_type b ALLOC) in
                              ((bset - {blo}) \<union> {newblo}, ids, True, {allocid}))"

definition alloc :: "Block set \<Rightarrow> nat \<Rightarrow> ID set \<Rightarrow> (Block set \<times> ID set \<times> bool \<times> ID set)"
  where "alloc bset lv ids \<equiv>
         if (exists_freelevel bset lv) then
            let lmax = freesets_maxlevel bset lv in
                if lmax = lv then
                   alloc1 bset lv ids
                else
                   let blo = (SOME b. b \<in> bset \<and> freesets_level b lmax \<noteq> {});
                       b = (SOME l. l \<in> freesets_level blo lmax);
                       re = split b ids (lv - lmax);
                       subbtr = fst re;
                       newids = fst (snd re);
                       allocid = snd (snd re);
                       newbtr = replace_leaf blo b subbtr in
                   (((bset - {blo}) \<union> {newbtr}), newids, True, {allocid})
         else (bset, ids, False, {})"

definition free :: "Block set \<Rightarrow> Block \<Rightarrow> ID set \<Rightarrow> (Block set \<times> ID set \<times> bool)"
  where "free bset b ids \<equiv>
         if (\<exists>btree \<in> bset. (L b) \<in> set btree) then
            if fst (L b) = FREE then
                (bset, ids, False)
            else
                let btree = (THE t. t \<in> bset \<and> (L b) \<in> set t);
                    freeblo = replace btree b (set_state_type b FREE);
                    re = merge freeblo ids;
                    newblo = fst re;
                    newids = snd re in
                ((bset - {btree}) \<union> {newblo}, newids, True)
         else
            (bset, ids, False)"

end


theory sort_NMSortTDPermutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = Nil2"
| "take (S z) (Nil2) = Nil2"
| "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

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

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) y = y"
| "drop (S z) (Nil2) = Nil2"
| "drop (S z) (Cons2 x2 x3) = drop z x3"

fun nmsorttd :: "int list => int list" where
"nmsorttd (Nil2) = Nil2"
| "nmsorttd (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "nmsorttd (Cons2 y (Cons2 x2 x3)) =
     lmerge
       (nmsorttd
          (take
             (half (length (Cons2 y (Cons2 x2 x3)))) (Cons2 y (Cons2 x2 x3))))
       (nmsorttd
          (drop
             (half (length (Cons2 y (Cons2 x2 x3)))) (Cons2 y (Cons2 x2 x3))))"

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

(*hipster take lmerge length half drop nmsorttd count *)

theorem x0 :
  "!! (x :: int) (y :: int list) .
     (count x (nmsorttd y)) = (count x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Support
  imports "../Nominal"
begin

text \<open>
  An example showing that in general

  x\<sharp>(A \<union> B) does not imply  x\<sharp>A and  x\<sharp>B

  For this we set A to the set of even atoms and B to
  the set of odd atoms. Then A \<union> B, that is the set of
  all atoms, has empty support. The sets A, respectively B,
  however have the set of all atoms as their support.
\<close>

atom_decl atom

text \<open>The set of even atoms.\<close>
abbreviation
  EVEN :: "atom set"
where
  "EVEN \<equiv> {atom n | n. \<exists>i. n=2*i}"

text \<open>The set of odd atoms:\<close>
abbreviation
  ODD :: "atom set"
where
  "ODD \<equiv> {atom n | n. \<exists>i. n=2*i+1}"

text \<open>An atom is either even or odd.\<close>
lemma even_or_odd:
  fixes n :: nat
  shows "\<exists>i. (n = 2*i) \<or> (n=2*i+1)"
  by (induct n) (presburger)+

text \<open>
  The union of even and odd atoms is the set of all atoms.
  (Unfortunately I do not know a simpler proof of this fact.)\<close>
lemma EVEN_union_ODD:
  shows "EVEN \<union> ODD = UNIV"
  using even_or_odd
proof -
  have "EVEN \<union> ODD = (\<lambda>n. atom n) ` {n. \<exists>i. n = 2*i} \<union> (\<lambda>n. atom n) ` {n. \<exists>i. n = 2*i+1}" by auto
  also have "\<dots> = (\<lambda>n. atom n) ` ({n. \<exists>i. n = 2*i} \<union> {n. \<exists>i. n = 2*i+1})" by auto
  also have "\<dots> = (\<lambda>n. atom n) ` ({n. \<exists>i. n = 2*i \<or> n = 2*i+1})" by auto
  also have "\<dots> = (\<lambda>n. atom n) ` (UNIV::nat set)" using even_or_odd by auto
  also have "\<dots> = (UNIV::atom set)" using atom.exhaust
    by (auto simp add: surj_def)
  finally show "EVEN \<union> ODD = UNIV" by simp
qed

text \<open>The sets of even and odd atoms are disjunct.\<close>
lemma EVEN_intersect_ODD:
  shows "EVEN \<inter> ODD = {}"
  using even_or_odd
  by (auto) (presburger)

text \<open>
  The preceeding two lemmas help us to prove
  the following two useful equalities:\<close>

lemma UNIV_subtract:
  shows "UNIV - EVEN = ODD"
  and   "UNIV - ODD  = EVEN"
  using EVEN_union_ODD EVEN_intersect_ODD
  by (blast)+

text \<open>The sets EVEN and ODD are infinite.\<close>
lemma EVEN_ODD_infinite:
  shows "infinite EVEN"
  and   "infinite ODD"
unfolding infinite_iff_countable_subset
proof -
  let ?f = "\<lambda>n. atom (2*n)"
  have "inj ?f \<and> range ?f \<subseteq> EVEN" by (auto simp add: inj_on_def)
  then show "\<exists>f::nat\<Rightarrow>atom. inj f \<and> range f \<subseteq> EVEN" by (rule_tac exI)
next
  let ?f = "\<lambda>n. atom (2*n+1)"
  have "inj ?f \<and> range ?f \<subseteq> ODD" by (auto simp add: inj_on_def)
  then show "\<exists>f::nat\<Rightarrow>atom. inj f \<and> range f \<subseteq> ODD" by (rule_tac exI)
qed

text \<open>
  A general fact about a set S of atoms that is both infinite and
  coinfinite. Then S has all atoms as its support. Steve Zdancewic
  helped with proving this fact.\<close>

lemma supp_infinite_coinfinite:
  fixes S::"atom set"
  assumes asm1: "infinite S"
  and     asm2: "infinite (UNIV-S)"
  shows "(supp S) = (UNIV::atom set)"
proof -
  have "\<forall>(x::atom). x\<in>(supp S)"
  proof
    fix x::"atom"
    show "x\<in>(supp S)"
    proof (cases "x\<in>S")
      case True
      have "x\<in>S" by fact
      hence "\<forall>b\<in>(UNIV-S). [(x,b)]\<bullet>S\<noteq>S" by (auto simp add: perm_set_def calc_atm)
      with asm2 have "infinite {b\<in>(UNIV-S). [(x,b)]\<bullet>S\<noteq>S}" by (rule infinite_Collection)
      hence "infinite {b. [(x,b)]\<bullet>S\<noteq>S}" by (rule_tac infinite_super, auto)
      then show "x\<in>(supp S)" by (simp add: supp_def)
    next
      case False
      have "x\<notin>S" by fact
      hence "\<forall>b\<in>S. [(x,b)]\<bullet>S\<noteq>S" by (auto simp add: perm_set_def calc_atm)
      with asm1 have "infinite {b\<in>S. [(x,b)]\<bullet>S\<noteq>S}" by (rule infinite_Collection)
      hence "infinite {b. [(x,b)]\<bullet>S\<noteq>S}" by (rule_tac infinite_super, auto)
      then show "x\<in>(supp S)" by (simp add: supp_def)
    qed
  qed
  then show "(supp S) = (UNIV::atom set)" by auto
qed

text \<open>As a corollary we get that EVEN and ODD have infinite support.\<close>
lemma EVEN_ODD_supp:
  shows "supp EVEN = (UNIV::atom set)"
  and   "supp ODD  = (UNIV::atom set)"
  using supp_infinite_coinfinite UNIV_subtract EVEN_ODD_infinite
  by simp_all

text \<open>
  The set of all atoms has empty support, since any swappings leaves
  this set unchanged.\<close>

lemma UNIV_supp:
  shows "supp (UNIV::atom set) = ({}::atom set)"
proof -
  have "\<forall>(x::atom) (y::atom). [(x,y)]\<bullet>UNIV = (UNIV::atom set)"
    by (auto simp add: perm_set_def calc_atm)
  then show "supp (UNIV::atom set) = ({}::atom set)" by (simp add: supp_def)
qed

text \<open>Putting everything together.\<close>
theorem EVEN_ODD_freshness:
  fixes x::"atom"
  shows "x\<sharp>(EVEN \<union> ODD)"
  and   "\<not>x\<sharp>EVEN"
  and   "\<not>x\<sharp>ODD"
  by (auto simp only: fresh_def EVEN_union_ODD EVEN_ODD_supp UNIV_supp)

text \<open>Moral: support is a sublte notion.\<close>

end


header "Weights for Dijkstra's Algorithm"
theory Weight
imports Complex_Main
begin

text {*
  In this theory, we set up a type class for weights, and
  a typeclass for weights with an infinity element. The latter
  one is used internally in Dijkstra's algorithm.

  Moreover, we provide a datatype that adds an infinity element to a given
  base type.
*}

subsection {* Type Classes Setup *}

class weight = ordered_ab_semigroup_add + comm_monoid_add + linorder
begin

lemma add_nonneg_nonneg [simp]:
  assumes "0 \<le> a" and "0 \<le> b" shows "0 \<le> a + b"
proof -
  have "0 + 0 \<le> a + b"
    using assms by (rule add_mono)
  then show ?thesis by simp
qed

lemma add_nonpos_nonpos[simp]:
  assumes "a \<le> 0" and "b \<le> 0" shows "a + b \<le> 0"
proof -
  have "a + b \<le> 0 + 0"
    using assms by (rule add_mono)
  then show ?thesis by simp
qed

lemma add_nonneg_eq_0_iff:
  assumes x: "0 \<le> x" and y: "0 \<le> y"
  shows "x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (metis add.comm_neutral add.left_neutral add_left_mono antisym x y)

lemma add_incr: "0\<le>b \<Longrightarrow> a \<le> a+b"
  by (metis add.comm_neutral add_left_mono)

lemma add_incr_left[simp, intro!]: "0\<le>b \<Longrightarrow> a \<le> b + a"
  by (metis add_incr add.commute)

lemma sum_not_less[simp, intro!]:
  "0\<le>b \<Longrightarrow> \<not> (a+b < a)"
  "0\<le>a \<Longrightarrow> \<not> (a+b < b)"
  apply (metis add_incr less_le_not_le)
  apply (metis add_incr_left less_le_not_le)
  done

end

instance nat :: weight ..
instance int :: weight ..
instance rat :: weight ..
instance real :: weight ..

term top

class top_weight = order_top + weight +
  assumes inf_add_right[simp]: "a + top = top"
begin

lemma inf_add_left[simp]: "top + a = top"
  by (metis add.commute inf_add_right)

lemmas [simp] = top_unique less_top[symmetric]

lemma not_less_inf[simp]:
  "\<not> (a < top) \<longleftrightarrow> a=top"
  by simp

end

subsection {* Adding Infinity *}
text {*
  We provide a standard way to add an infinity element to any type.
*}

datatype 'a infty = Infty | Num 'a

primrec val where "val (Num d) = d"

lemma num_val_iff[simp]: "e\<noteq>Infty \<Longrightarrow> Num (val e) = e" by (cases e) auto

type_synonym NatB = "nat infty"

instantiation infty :: (weight) top_weight
begin
  definition "(0::'a infty) == Num 0"
  definition "top \<equiv> Infty"

  fun less_eq_infty where
    "less_eq Infty (Num _) \<longleftrightarrow> False" |
    "less_eq _ Infty \<longleftrightarrow> True" |
    "less_eq (Num a) (Num b) \<longleftrightarrow> a\<le>b"

  fun less_infty where
    "less Infty _ \<longleftrightarrow> False" |
    "less (Num _) Infty \<longleftrightarrow> True" |
    "less (Num a) (Num b) \<longleftrightarrow> a<b"

  lemma [simp]: "less a Infty \<longleftrightarrow> a \<noteq> Infty"
    by (cases a) auto

  fun plus_infty where
    "plus _ Infty = Infty" |
    "plus Infty _ = Infty" |
    "plus (Num a) (Num b) = Num (a+b)"

  lemma [simp]: "plus Infty a = Infty" by (cases a) simp_all

  instance
    apply (intro_classes)
    apply (case_tac [!] x) [4]
    apply simp_all
    apply (case_tac [!] y) [3]
    apply (simp_all add: less_le_not_le)
    apply (case_tac z)
    apply (simp_all add: top_infty_def zero_infty_def)
    apply (case_tac [!] a) [4]
    apply simp_all
    apply (case_tac [!] b) [3]
    apply (simp_all add: ac_simps)
    apply (case_tac [!] c) [2]
    apply (simp_all add: ac_simps add_right_mono)
    apply (case_tac "(x,y)" rule: less_eq_infty.cases)
    apply (simp_all add: linear)
    done
end

subsubsection {* Unboxing *}

text {* Conversion between the constants defined by the
  typeclass, and the concrete functions on the @{typ "'a infty"} type.
*}
lemma infty_inf_unbox:
  "Num a \<noteq> top"
  "top \<noteq> Num a"
  "Infty = top"
  by (auto simp add: top_infty_def)

lemma infty_ord_unbox:
  "Num a \<le> Num b \<longleftrightarrow> a \<le> b"
  "Num a < Num b \<longleftrightarrow> a < b"
  by auto

lemma infty_plus_unbox:
  "Num a + Num b = Num (a+b)"
  by (auto)

lemma infty_zero_unbox:
  "Num a = 0 \<longleftrightarrow> a = 0"
  "Num 0 = 0"
  by (auto simp: zero_infty_def)

lemmas infty_unbox =
  infty_inf_unbox infty_zero_unbox infty_ord_unbox infty_plus_unbox

lemma inf_not_zero[simp]:
  "top\<noteq>(0::_ infty)" "(0::_ infty)\<noteq>top"
  apply (unfold zero_infty_def top_infty_def)
  apply auto
  done

lemma num_val_iff'[simp]: "e\<noteq>top \<Longrightarrow> Num (val e) = e"
  by (cases e) (auto simp add: infty_unbox)

lemma infty_neE:
  "\<lbrakk>a\<noteq>Infty; \<And>d. a=Num d \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  "\<lbrakk>a\<noteq>top; \<And>d. a=Num d \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (case_tac [!] a) (auto simp add: infty_unbox)

end


theory sort_MSortBU2Sorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun risers :: "int list => (int list) list" where
"risers (Nil2) = Nil2"
| "risers (Cons2 y (Nil2)) = Cons2 (Cons2 y (Nil2)) (Nil2)"
| "risers (Cons2 y (Cons2 y2 xs)) =
     (if y <= y2 then
        case risers (Cons2 y2 xs) of
          | Nil2 => risers (Cons2 y2 xs)
          | Cons2 ys yss => Cons2 (Cons2 y ys) yss
        end
        else
        Cons2 (Cons2 y (Nil2)) (risers (Cons2 y2 xs)))"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int 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 mergingbu2 :: "(int list) list => int list" where
"mergingbu2 (Nil2) = Nil2"
| "mergingbu2 (Cons2 xs (Nil2)) = xs"
| "mergingbu2 (Cons2 xs (Cons2 z x2)) =
     mergingbu2 (pairwise (Cons2 xs (Cons2 z x2)))"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun msortbu2 :: "int list => int list" where
"msortbu2 x =
   dot
     (% (y :: (int list) list) => mergingbu2 y)
     (% (z :: int list) => risers z) x"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "int list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (y <= y2) (ordered (Cons2 y2 xs))"

(*hipster risers
          lmerge
          pairwise
          mergingbu2
          dot
          msortbu2
          and2
          ordered *)

theorem x0 :
  "!! (x :: int list) . ordered (msortbu2 x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end