(* -------------------------------------------------------------------------- *)
subsection \<open>Hermitean matrices\<close>
(* -------------------------------------------------------------------------- *)

text \<open>Hermitean matrices over $\mathbb{C}$ generalize symmetric matrices over $\mathbb{R}$. Quadratic
forms with Hermitean matrices represent circles and lines in the extended complex plane (when
applied to homogenous coordinates).\<close>

theory Hermitean_Matrices
imports Unitary_Matrices
begin

definition hermitean :: "complex_mat \<Rightarrow> bool" where
 "hermitean A \<longleftrightarrow> mat_adj A = A"

lemma hermitean_transpose:
  shows "hermitean A \<longleftrightarrow> mat_transpose A = mat_cnj A"
  unfolding hermitean_def
  by (cases A) (auto simp add: mat_adj_def mat_cnj_def)

text \<open>Characterization of 2x2 Hermitean matrices elements.
All 2x2 Hermitean matrices are of the form
$$
\left(
\begin{array}{cc}
A & B\\
\overline{B} & D
\end{array}
\right),
$$
for real $A$ and $D$ and complex $B$.
\<close>

lemma hermitean_mk_circline [simp]:
  shows "hermitean (cor A, B, cnj B, cor D)"
  unfolding hermitean_def mat_adj_def mat_cnj_def
  by simp

lemma hermitean_elems:
  assumes "hermitean (A, B, C, D)"
  shows "is_real A" and "is_real D" and "B = cnj C" and "cnj B = C"
  using assms eq_cnj_iff_real[of A] eq_cnj_iff_real[of D]
  by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)

text \<open>Operations that preserve the Hermitean property\<close>

lemma hermitean_mat_cnj:
  shows "hermitean H \<longleftrightarrow> hermitean (mat_cnj H)"
  by (cases H) (auto simp add:  hermitean_def mat_adj_def mat_cnj_def)

lemma hermitean_mult_real:
  assumes "hermitean H"
  shows "hermitean ((cor k) *\<^sub>s\<^sub>m H)"
  using assms
  unfolding hermitean_def
  by simp

lemma hermitean_congruence:
  assumes "hermitean H"
  shows "hermitean (congruence M H)"
  using assms
  unfolding hermitean_def
  by (auto simp add: mult_mm_assoc)

text \<open>Identity matrix is Hermitean\<close>

lemma hermitean_eye [simp]:
  shows "hermitean eye"
  by (auto simp add:  hermitean_def mat_adj_def mat_cnj_def)

lemma hermitean_eye' [simp]:
  shows "hermitean (1, 0, 0, 1)"
  by (auto simp add:  hermitean_def mat_adj_def mat_cnj_def)

text \<open>Unit circle matrix is Hermitean\<close>

lemma hermitean_unit_circle [simp]:
  shows "hermitean (1, 0, 0, -1)"
  by (auto simp add:  hermitean_def mat_adj_def mat_cnj_def)

text \<open>Hermitean matrices have real determinant\<close>
lemma mat_det_hermitean_real:
  assumes "hermitean A"
  shows "is_real (mat_det A)"
  using assms
  unfolding hermitean_def
  by (metis eq_cnj_iff_real mat_det_adj)

text \<open>Zero matrix is the only Hermitean matrix with both determinant and trace equal
to zero\<close>
lemma hermitean_det_zero_trace_zero:
  assumes "mat_det A = 0" and "mat_trace A = (0::complex)" and "hermitean A"
  shows "A = mat_zero"
using assms
proof-
  {
    fix a d c
    assume "a * d = cnj c * c" "a + d = 0" "cnj a = a"
    from \<open>a + d = 0\<close> have "d = -a"
      by (metis add_eq_0_iff)
    hence "- (cor (Re a))\<^sup>2  = (cor (cmod c))\<^sup>2"
      using \<open>cnj a = a\<close> eq_cnj_iff_real[of a]
      using \<open>a*d = cnj c * c\<close>
      using complex_mult_cnj_cmod[of "cnj c"]
      by (simp add: power2_eq_square)
    hence "- (Re a)\<^sup>2 \<ge> 0"
      using zero_le_power2[of "cmod c"]
      by (metis Re_complex_of_real cor_squared of_real_minus)
    hence "a = 0"
      using zero_le_power2[of "Re a"]
      using \<open>cnj a = a\<close>  eq_cnj_iff_real[of a]
      by (simp add: complex_eq_if_Re_eq)
  } note * = this
  obtain a b c d where "A = (a, b, c, d)"
    by (cases A) auto
  thus ?thesis
    using *[of a d c]  *[of d a c]
    using assms \<open>A = (a, b, c, d)\<close>
    by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
qed

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Bilinear and quadratic forms with Hermitean matrices\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>A Hermitean matrix $(A, B, \overline{B}, D)$, for real $A$ and $D$, gives rise to bilinear form
$A\cdot \overline{v_{11}} \cdot v_{21}+\overline{B} \cdot \overline{v_{12}} \cdot v_{21} +
B \cdot \overline{v_{11}} \cdot v_{22}+D\cdot \overline{v_{12}}\cdot v_{22}$ (acting on vectors $(v_{11}, v_{12})$ and
$(v_{21}, v_{22})$) and to the quadratic form $A \cdot \overline{v_1} \cdot v_1+\overline{B}\cdot \overline{v_2}\cdot v_1 +
B\cdot \overline{v_1}\cdot v_2 + D\cdot \overline{v_2} \cdot v_2$ (acting on the vector $(v_1, v_2)$).\<close>

lemma bilinear_form_hermitean_commute:
  assumes "hermitean H"
  shows "bilinear_form v1 v2 H = cnj (bilinear_form v2 v1 H)"
proof-
  have "v2 *\<^sub>v\<^sub>m mat_cnj H *\<^sub>v\<^sub>v vec_cnj v1 = vec_cnj v1 *\<^sub>v\<^sub>v (mat_adj H *\<^sub>m\<^sub>v v2)"
    by (subst mult_vv_commute, subst mult_mv_mult_vm, simp add: mat_adj_def mat_transpose_mat_cnj)
  also
  have "\<dots> = bilinear_form v1 v2 H"
    using assms
    by (simp add: mult_vv_mv hermitean_def)
  finally
  show ?thesis
    by (simp add: cnj_mult_vv vec_cnj_mult_vm)
qed

lemma quad_form_hermitean_real:
  assumes "hermitean H"
  shows "is_real (quad_form z H)"
  using assms
  by (subst eq_cnj_iff_real[symmetric])  (simp del: quad_form_def add: hermitean_def)

lemma quad_form_vec_cnj_mat_cnj:
  assumes "hermitean H"
  shows "quad_form (vec_cnj z) (mat_cnj H) = quad_form z H"
  using assms
  using cnj_mult_vv cnj_quad_form hermitean_def vec_cnj_mult_vm by auto

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Eigenvalues, eigenvectors and diagonalization of Hermitean matrices\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Hermitean matrices have real eigenvalues\<close>
lemma hermitean_eigenval_real:
  assumes "hermitean H" and "eigenval k H"
  shows "is_real k"
proof-
  from assms obtain v where "v \<noteq> vec_zero" "H *\<^sub>m\<^sub>v v = k *\<^sub>s\<^sub>v v"
    unfolding eigenval_def
    by blast
  have "k * (v *\<^sub>v\<^sub>v vec_cnj v) = (k *\<^sub>s\<^sub>v v) *\<^sub>v\<^sub>v (vec_cnj v)"
    by (simp add: mult_vv_scale_sv1)
  also have "... = (H *\<^sub>m\<^sub>v v) *\<^sub>v\<^sub>v (vec_cnj v)"
    using \<open>H *\<^sub>m\<^sub>v v = k *\<^sub>s\<^sub>v v\<close>
    by simp
  also have "... =  v *\<^sub>v\<^sub>v (mat_transpose H *\<^sub>m\<^sub>v (vec_cnj v))"
    by (simp add: mult_mv_vv)
  also have "... = v *\<^sub>v\<^sub>v (vec_cnj (mat_cnj (mat_transpose H) *\<^sub>m\<^sub>v v))"
    by (simp add: vec_cnj_mult_mv)
  also have "... = v *\<^sub>v\<^sub>v (vec_cnj (H *\<^sub>m\<^sub>v v))"
    using \<open>hermitean H\<close>
    by (simp add: hermitean_def mat_adj_def)
  also have "... = v *\<^sub>v\<^sub>v (vec_cnj (k *\<^sub>s\<^sub>v v))"
    using \<open>H *\<^sub>m\<^sub>v v = k *\<^sub>s\<^sub>v v\<close>
    by simp
  finally have "k * (v *\<^sub>v\<^sub>v vec_cnj v) = cnj k * (v *\<^sub>v\<^sub>v vec_cnj v)"
    by (simp add: mult_vv_scale_sv2)
  hence "k = cnj k"
    using \<open>v \<noteq> vec_zero\<close>
    using scalsquare_vv_zero[of v]
    by (simp add: mult_vv_commute)
  thus ?thesis
    by (metis eq_cnj_iff_real)
qed

text \<open>Non-diagonal Hermitean matrices have distinct eigenvalues\<close>
lemma hermitean_distinct_eigenvals:
  assumes "hermitean H"
  shows "(\<exists> k\<^sub>1 k\<^sub>2. k\<^sub>1 \<noteq> k\<^sub>2 \<and> eigenval k\<^sub>1 H \<and> eigenval k\<^sub>2 H) \<or> mat_diagonal H"
proof-
  obtain A B C D where HH: "H = (A, B, C, D)"
    by (cases H) auto
  show ?thesis
  proof (cases "B = 0")
    case True
    thus ?thesis
      using \<open>hermitean H\<close> hermitean_elems[of A B C D] HH
      by auto
  next
    case False
    have "(mat_trace H)\<^sup>2 \<noteq> 4 * mat_det H"
    proof (rule ccontr)
      have "C = cnj B" "is_real A" "is_real D"
        using hermitean_elems HH \<open>hermitean H\<close>
        by auto
      assume "\<not> ?thesis"
      hence "(A + D)\<^sup>2 = 4*(A*D - B*C)"
        using HH
        by auto
      hence "(A - D)\<^sup>2 = - 4*B*cnj B"
        using \<open>C = cnj B\<close>
        by (auto simp add: power2_eq_square field_simps)
      hence "(A - D)\<^sup>2 / cor ((cmod B)\<^sup>2) = -4"
        using \<open>B \<noteq> 0\<close> complex_mult_cnj_cmod[of B]
        by (auto simp add: field_simps)
      hence "(Re A - Re D)\<^sup>2 / (cmod B)\<^sup>2 = -4"
        using \<open>is_real A\<close> \<open>is_real D\<close> \<open>B \<noteq> 0\<close>
        using Re_divide_real[of "cor ((cmod B)\<^sup>2)" "(A - D)\<^sup>2"]
        by (auto simp add: power2_eq_square)
      thus False
        by (metis abs_neg_numeral abs_power2 neg_numeral_neq_numeral power_divide)
    qed
    show ?thesis
      apply (rule disjI1)
      apply (subst eigen_equation)+
      using complex_quadratic_equation_monic_distinct_roots[of "-mat_trace H" "mat_det H"] \<open>(mat_trace H)\<^sup>2 \<noteq> 4 * mat_det H\<close>
      by auto
  qed
qed

text \<open>Eigenvectors corresponding to different eigenvalues of Hermitean matrices are
orthogonal\<close>
lemma hermitean_ortho_eigenvecs:
  assumes "hermitean H"
  assumes "eigenpair k1 v1 H" and "eigenpair k2 v2 H" and "k1 \<noteq> k2"
  shows "vec_cnj v2 *\<^sub>v\<^sub>v v1 = 0" and "vec_cnj v1 *\<^sub>v\<^sub>v v2 = 0"
proof-
  from assms
  have "v1 \<noteq> vec_zero" "H *\<^sub>m\<^sub>v v1 = k1 *\<^sub>s\<^sub>v v1"
       "v2 \<noteq> vec_zero" "H *\<^sub>m\<^sub>v v2 = k2 *\<^sub>s\<^sub>v v2"
    unfolding eigenpair_def
    by auto
  have real_k: "is_real k1" "is_real k2"
    using assms
    using hermitean_eigenval_real[of H k1]
    using hermitean_eigenval_real[of H k2]
    unfolding eigenpair_def eigenval_def
    by blast+

  have "vec_cnj (H *\<^sub>m\<^sub>v v2) = vec_cnj (k2 *\<^sub>s\<^sub>v v2)"
    using \<open>H *\<^sub>m\<^sub>v v2 = k2 *\<^sub>s\<^sub>v v2\<close>
    by auto
  hence "vec_cnj v2 *\<^sub>v\<^sub>m H  = k2 *\<^sub>s\<^sub>v vec_cnj v2"
    using \<open>hermitean H\<close> real_k eq_cnj_iff_real[of k1] eq_cnj_iff_real[of k2]
    unfolding hermitean_def
    by (cases H, cases v2) (auto simp add: mat_adj_def mat_cnj_def vec_cnj_def)
  have "k2 * (vec_cnj v2 *\<^sub>v\<^sub>v v1) = k1 * (vec_cnj v2 *\<^sub>v\<^sub>v v1)"
    using \<open>H *\<^sub>m\<^sub>v v1 = k1 *\<^sub>s\<^sub>v v1\<close>
    using \<open>vec_cnj v2 *\<^sub>v\<^sub>m H  = k2 *\<^sub>s\<^sub>v vec_cnj v2\<close>
    by (cases v1, cases v2, cases H)
       (metis mult_vv_mv mult_vv_scale_sv1 mult_vv_scale_sv2)
  thus "vec_cnj v2 *\<^sub>v\<^sub>v v1 = 0"
    using \<open>k1 \<noteq> k2\<close>
    by simp
  hence "cnj (vec_cnj v2 *\<^sub>v\<^sub>v v1) = 0"
    by simp
  thus "vec_cnj v1 *\<^sub>v\<^sub>v v2 = 0"
    by (simp add: cnj_mult_vv mult_vv_commute)
qed

text \<open>Hermitean matrices are diagonizable by unitary matrices. Diagonal entries are
real and the sign of the determinant is preserved.\<close>
lemma hermitean_diagonizable:
  assumes "hermitean H"
  shows "\<exists> k1 k2 M. mat_det M \<noteq> 0 \<and> unitary M \<and> congruence M H = (k1, 0, 0, k2) \<and>
                    is_real k1 \<and> is_real k2 \<and> sgn (Re k1 * Re k2) = sgn (Re (mat_det H))"
proof-
  from assms
  have "(\<exists>k\<^sub>1 k\<^sub>2. k\<^sub>1 \<noteq> k\<^sub>2 \<and> eigenval k\<^sub>1 H \<and> eigenval k\<^sub>2 H) \<or> mat_diagonal H"
    using hermitean_distinct_eigenvals[of H]
    by simp
  thus ?thesis
  proof
    assume "\<exists>k\<^sub>1 k\<^sub>2. k\<^sub>1 \<noteq> k\<^sub>2 \<and> eigenval k\<^sub>1 H \<and> eigenval k\<^sub>2 H"
    then  obtain k1 k2 where  "k1 \<noteq> k2" "eigenval k1 H" "eigenval k2 H"
      using hermitean_distinct_eigenvals
      by blast
    then obtain v1 v2 where "eigenpair k1 v1 H" "eigenpair k2 v2 H"
      "v1 \<noteq> vec_zero" "v2 \<noteq> vec_zero"
      unfolding eigenval_def eigenpair_def
      by blast
    hence *: "vec_cnj v2 *\<^sub>v\<^sub>v v1 = 0" "vec_cnj v1 *\<^sub>v\<^sub>v v2 = 0"
      using \<open>k1 \<noteq> k2\<close> hermitean_ortho_eigenvecs \<open>hermitean H\<close>
      by auto
    obtain v11 v12 v21 v22 where vv: "v1 = (v11, v12)" "v2 = (v21, v22)"
      by  (cases v1, cases v2) auto
    let ?nv1' = "vec_cnj v1 *\<^sub>v\<^sub>v v1" and ?nv2' = "vec_cnj v2 *\<^sub>v\<^sub>v v2"
    let ?nv1 = "cor (sqrt (Re ?nv1'))"
    let ?nv2 = "cor (sqrt (Re ?nv2'))"
    have "?nv1' \<noteq> 0"  "?nv2' \<noteq> 0"
      using \<open>v1 \<noteq> vec_zero\<close> \<open>v2 \<noteq> vec_zero\<close> vv
      by (simp add: scalsquare_vv_zero)+
    moreover
    have "is_real ?nv1'" "is_real ?nv2'"
      using vv
      by (auto simp add: vec_cnj_def)
    ultimately
    have "?nv1 \<noteq> 0"  "?nv2 \<noteq> 0"
      using complex_eq_if_Re_eq
      by auto
    have "Re (?nv1') \<ge> 0"  "Re (?nv2') \<ge> 0"
      using vv
      by (auto simp add: vec_cnj_def)
    obtain nv1 nv2 where "nv1 = ?nv1" "nv1 \<noteq> 0"  "nv2 = ?nv2" "nv2 \<noteq> 0"
      using \<open>?nv1 \<noteq> 0\<close>  \<open>?nv2 \<noteq> 0\<close>
      by auto
    let ?M = "(1/nv1 * v11, 1/nv2 * v21, 1/nv1 * v12, 1/nv2 * v22)"

    have "is_real k1" "is_real k2"
      using  \<open>eigenval k1 H\<close> \<open>eigenval k2 H\<close> \<open>hermitean H\<close>
      by (auto simp add: hermitean_eigenval_real)
    moreover
    have "mat_det ?M \<noteq> 0"
    proof (rule ccontr)
      assume "\<not> ?thesis"
      hence "v11 * v22 = v12 * v21"
        using \<open>nv1 \<noteq> 0\<close> \<open>nv2 \<noteq> 0\<close>
        by (auto simp add: field_simps)
      hence "\<exists> k. k \<noteq> 0 \<and> v2 = k *\<^sub>s\<^sub>v v1"
        using vv \<open>v1 \<noteq> vec_zero\<close> \<open>v2 \<noteq> vec_zero\<close>
        apply auto
        apply (rule_tac x="v21/v11" in exI, force simp add: field_simps)
        apply (rule_tac x="v21/v11" in exI, force simp add: field_simps)
        apply (rule_tac x="v22/v12" in exI, force simp add: field_simps)
        apply (rule_tac x="v22/v12" in exI, force simp add: field_simps)
        done
      thus False
        using * \<open>vec_cnj v1 *\<^sub>v\<^sub>v v2 = 0\<close> \<open>vec_cnj v2 *\<^sub>v\<^sub>v v2 \<noteq> 0\<close> vv \<open>?nv1' \<noteq> 0\<close>
        by (metis mult_vv_scale_sv2 mult_zero_right)
    qed
    moreover
    have "unitary ?M"
    proof-
      have **: "cnj nv1 * nv1 = ?nv1'"  "cnj nv2 * nv2 = ?nv2'"
        using \<open>nv1 = ?nv1\<close> \<open>nv1 \<noteq> 0\<close>  \<open>nv2 = ?nv2\<close> \<open>nv2 \<noteq> 0\<close> \<open>is_real ?nv1'\<close> \<open>is_real ?nv2'\<close>
        using \<open>Re (?nv1') \<ge> 0\<close>  \<open>Re (?nv2') \<ge> 0\<close>
        by auto
      have ***: "cnj nv1 * nv2 \<noteq> 0"  "cnj nv2 * nv1 \<noteq> 0"
        using vv \<open>nv1 = ?nv1\<close> \<open>nv1 \<noteq> 0\<close>  \<open>nv2 = ?nv2\<close> \<open>nv2 \<noteq> 0\<close> \<open>is_real ?nv1'\<close> \<open>is_real ?nv2'\<close>
        by auto

      show ?thesis
        unfolding unitary_def
        using vv ** \<open>?nv1' \<noteq> 0\<close> \<open>?nv2' \<noteq> 0\<close> * ***
        unfolding mat_adj_def mat_cnj_def vec_cnj_def
        by simp (metis (no_types, lifting) add_divide_distrib divide_eq_0_iff divide_eq_1_iff)
    qed
    moreover
    have "congruence ?M H = (k1, 0, 0, k2)"
    proof-
      have "mat_inv ?M *\<^sub>m\<^sub>m H *\<^sub>m\<^sub>m ?M = (k1, 0, 0, k2)"
      proof-
        have *: "H *\<^sub>m\<^sub>m ?M = ?M *\<^sub>m\<^sub>m (k1, 0, 0, k2)"
          using \<open>eigenpair k1 v1 H\<close> \<open>eigenpair k2 v2 H\<close> vv \<open>?nv1 \<noteq> 0\<close> \<open>?nv2 \<noteq> 0\<close>
          unfolding eigenpair_def vec_cnj_def
          by (cases H) (smt mult_mm.simps vec_map.simps add.right_neutral add_cancel_left_left distrib_left fst_mult_sv mult.commute mult.left_commute mult_mv.simps mult_zero_right prod.sel(1) prod.sel(2) snd_mult_sv)
        show ?thesis
          using mult_mm_inv_l[of ?M "(k1, 0, 0, k2)" "H *\<^sub>m\<^sub>m ?M", OF \<open>mat_det ?M \<noteq> 0\<close> *[symmetric], symmetric]
          by (simp add: mult_mm_assoc)
      qed
      moreover
      have "mat_inv ?M = mat_adj ?M"
        using \<open>mat_det ?M \<noteq> 0\<close> \<open>unitary ?M\<close> mult_mm_inv_r[of ?M "mat_adj ?M" eye]
        by (simp add: unitary_def)
      ultimately
      show ?thesis
        by simp
    qed
    moreover
    have "sgn (Re k1 * Re k2) = sgn (Re (mat_det H))"
      using \<open>congruence ?M H = (k1, 0, 0, k2)\<close> \<open>is_real k1\<close> \<open>is_real k2\<close>
      using Re_det_sgn_congruence[of ?M H] \<open>mat_det ?M \<noteq> 0\<close> \<open>hermitean H\<close>
      by simp
    ultimately
    show ?thesis
      by (rule_tac x="k1" in exI, rule_tac x="k2" in exI, rule_tac x="?M" in exI) simp
  next
    assume "mat_diagonal H"
    then obtain A D where "H = (A, 0, 0, D)"
      by (cases H) auto
    moreover
    hence "is_real A" "is_real D"
      using \<open>hermitean H\<close> hermitean_elems[of A 0 0 D]
      by auto
    ultimately
    show ?thesis
      by (rule_tac x="A" in exI, rule_tac x="D" in exI, rule_tac x="eye" in exI) (simp add: unitary_def mat_adj_def mat_cnj_def)
  qed
qed

end


(*  Title:      HOL/ex/Primrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1997  University of Cambridge

Ackermann's Function and the
Primitive Recursive Functions.
*)

section \<open>Primitive Recursive Functions\<close>

theory Primrec imports Main begin

text \<open>
  Proof adopted from

  Nora Szasz, A Machine Checked Proof that Ackermann's Function is not
  Primitive Recursive, In: Huet \& Plotkin, eds., Logical Environments
  (CUP, 1993), 317-338.

  See also E. Mendelson, Introduction to Mathematical Logic.  (Van
  Nostrand, 1964), page 250, exercise 11.
  \medskip
\<close>

subsection\<open>Ackermann's Function\<close>

fun ack :: "nat => nat => nat" where
"ack 0 n =  Suc n" |
"ack (Suc m) 0 = ack m 1" |
"ack (Suc m) (Suc n) = ack m (ack (Suc m) n)"

text \<open>PROPERTY A 4\<close>

lemma less_ack2 [iff]: "j < ack i j"
by (induct i j rule: ack.induct) simp_all

text \<open>PROPERTY A 5-, the single-step lemma\<close>

lemma ack_less_ack_Suc2 [iff]: "ack i j < ack i (Suc j)"
by (induct i j rule: ack.induct) simp_all

text \<open>PROPERTY A 5, monotonicity for \<open><\<close>\<close>

lemma ack_less_mono2: "j < k ==> ack i j < ack i k"
using lift_Suc_mono_less[where f = "ack i"]
by (metis ack_less_ack_Suc2)

text \<open>PROPERTY A 5', monotonicity for \<open>\<le>\<close>\<close>

lemma ack_le_mono2: "j \<le> k ==> ack i j \<le> ack i k"
apply (simp add: order_le_less)
apply (blast intro: ack_less_mono2)
done

text \<open>PROPERTY A 6\<close>

lemma ack2_le_ack1 [iff]: "ack i (Suc j) \<le> ack (Suc i) j"
proof (induct j)
  case 0 show ?case by simp
next
  case (Suc j) show ?case
    by (auto intro!: ack_le_mono2)
      (metis Suc Suc_leI Suc_lessI less_ack2 linorder_not_less)
qed

text \<open>PROPERTY A 7-, the single-step lemma\<close>

lemma ack_less_ack_Suc1 [iff]: "ack i j < ack (Suc i) j"
by (blast intro: ack_less_mono2 less_le_trans)

text \<open>PROPERTY A 4'? Extra lemma needed for @{term CONSTANT} case, constant functions\<close>

lemma less_ack1 [iff]: "i < ack i j"
apply (induct i)
 apply simp_all
apply (blast intro: Suc_leI le_less_trans)
done

text \<open>PROPERTY A 8\<close>

lemma ack_1 [simp]: "ack (Suc 0) j = j + 2"
by (induct j) simp_all

text \<open>PROPERTY A 9.  The unary \<open>1\<close> and \<open>2\<close> in @{term
  ack} is essential for the rewriting.\<close>

lemma ack_2 [simp]: "ack (Suc (Suc 0)) j = 2 * j + 3"
by (induct j) simp_all

text \<open>PROPERTY A 7, monotonicity for \<open><\<close> [not clear why
  @{thm [source] ack_1} is now needed first!]\<close>

lemma ack_less_mono1_aux: "ack i k < ack (Suc (i +i')) k"
proof (induct i k rule: ack.induct)
  case (1 n) show ?case
    by (simp, metis ack_less_ack_Suc1 less_ack2 less_trans_Suc)
next
  case (2 m) thus ?case by simp
next
  case (3 m n) thus ?case
    by (simp, blast intro: less_trans ack_less_mono2)
qed

lemma ack_less_mono1: "i < j ==> ack i k < ack j k"
apply (drule less_imp_Suc_add)
apply (blast intro!: ack_less_mono1_aux)
done

text \<open>PROPERTY A 7', monotonicity for \<open>\<le>\<close>\<close>

lemma ack_le_mono1: "i \<le> j ==> ack i k \<le> ack j k"
apply (simp add: order_le_less)
apply (blast intro: ack_less_mono1)
done

text \<open>PROPERTY A 10\<close>

lemma ack_nest_bound: "ack i1 (ack i2 j) < ack (2 + (i1 + i2)) j"
apply simp
apply (rule ack2_le_ack1 [THEN [2] less_le_trans])
apply simp
apply (rule le_add1 [THEN ack_le_mono1, THEN le_less_trans])
apply (rule ack_less_mono1 [THEN ack_less_mono2])
apply (simp add: le_imp_less_Suc le_add2)
done

text \<open>PROPERTY A 11\<close>

lemma ack_add_bound: "ack i1 j + ack i2 j < ack (4 + (i1 + i2)) j"
apply (rule less_trans [of _ "ack (Suc (Suc 0)) (ack (i1 + i2) j)"])
 prefer 2
 apply (rule ack_nest_bound [THEN less_le_trans])
 apply (simp add: Suc3_eq_add_3)
apply simp
apply (cut_tac i = i1 and m1 = i2 and k = j in le_add1 [THEN ack_le_mono1])
apply (cut_tac i = "i2" and m1 = i1 and k = j in le_add2 [THEN ack_le_mono1])
apply auto
done

text \<open>PROPERTY A 12.  Article uses existential quantifier but the ALF proof
  used \<open>k + 4\<close>.  Quantified version must be nested \<open>\<exists>k'. \<forall>i j. ...\<close>\<close>

lemma ack_add_bound2: "i < ack k j ==> i + j < ack (4 + k) j"
apply (rule less_trans [of _ "ack k j + ack 0 j"])
 apply (blast intro: add_less_mono)
apply (rule ack_add_bound [THEN less_le_trans])
apply simp
done

subsection\<open>Primitive Recursive Functions\<close>

primrec hd0 :: "nat list => nat" where
"hd0 [] = 0" |
"hd0 (m # ms) = m"

text \<open>Inductive definition of the set of primitive recursive functions of type @{typ "nat list => nat"}.\<close>

definition SC :: "nat list => nat" where
"SC l = Suc (hd0 l)"

definition CONSTANT :: "nat => nat list => nat" where
"CONSTANT k l = k"

definition PROJ :: "nat => nat list => nat" where
"PROJ i l = hd0 (drop i l)"

definition
COMP :: "(nat list => nat) => (nat list => nat) list => nat list => nat"
where "COMP g fs l = g (map (\<lambda>f. f l) fs)"

definition PREC :: "(nat list => nat) => (nat list => nat) => nat list => nat"
where
  "PREC f g l =
    (case l of
      [] => 0
    | x # l' => rec_nat (f l') (\<lambda>y r. g (r # y # l')) x)"
  \<comment> \<open>Note that @{term g} is applied first to @{term "PREC f g y"} and then to @{term y}!\<close>

inductive PRIMREC :: "(nat list => nat) => bool" where
SC: "PRIMREC SC" |
CONSTANT: "PRIMREC (CONSTANT k)" |
PROJ: "PRIMREC (PROJ i)" |
COMP: "PRIMREC g ==> \<forall>f \<in> set fs. PRIMREC f ==> PRIMREC (COMP g fs)" |
PREC: "PRIMREC f ==> PRIMREC g ==> PRIMREC (PREC f g)"

text \<open>Useful special cases of evaluation\<close>

lemma SC [simp]: "SC (x # l) = Suc x"
by (simp add: SC_def)

lemma CONSTANT [simp]: "CONSTANT k l = k"
by (simp add: CONSTANT_def)

lemma PROJ_0 [simp]: "PROJ 0 (x # l) = x"
by (simp add: PROJ_def)

lemma COMP_1 [simp]: "COMP g [f] l = g [f l]"
by (simp add: COMP_def)

lemma PREC_0 [simp]: "PREC f g (0 # l) = f l"
by (simp add: PREC_def)

lemma PREC_Suc [simp]: "PREC f g (Suc x # l) = g (PREC f g (x # l) # x # l)"
by (simp add: PREC_def)

text \<open>MAIN RESULT\<close>

lemma SC_case: "SC l < ack 1 (sum_list l)"
apply (unfold SC_def)
apply (induct l)
apply (simp_all add: le_add1 le_imp_less_Suc)
done

lemma CONSTANT_case: "CONSTANT k l < ack k (sum_list l)"
by simp

lemma PROJ_case: "PROJ i l < ack 0 (sum_list l)"
apply (simp add: PROJ_def)
apply (induct l arbitrary:i)
 apply (auto simp add: drop_Cons split: nat.split)
apply (blast intro: less_le_trans le_add2)
done

text \<open>@{term COMP} case\<close>

lemma COMP_map_aux: "\<forall>f \<in> set fs. PRIMREC f \<and> (\<exists>kf. \<forall>l. f l < ack kf (sum_list l))
  ==> \<exists>k. \<forall>l. sum_list (map (\<lambda>f. f l) fs) < ack k (sum_list l)"
apply (induct fs)
 apply (rule_tac x = 0 in exI)
 apply simp
apply simp
apply (blast intro: add_less_mono ack_add_bound less_trans)
done

lemma COMP_case:
  "\<forall>l. g l < ack kg (sum_list l) ==>
  \<forall>f \<in> set fs. PRIMREC f \<and> (\<exists>kf. \<forall>l. f l < ack kf (sum_list l))
  ==> \<exists>k. \<forall>l. COMP g fs  l < ack k (sum_list l)"
apply (unfold COMP_def)
apply (drule COMP_map_aux)
apply (meson ack_less_mono2 ack_nest_bound less_trans)
done

text \<open>@{term PREC} case\<close>

lemma PREC_case_aux:
  "\<forall>l. f l + sum_list l < ack kf (sum_list l) ==>
    \<forall>l. g l + sum_list l < ack kg (sum_list l) ==>
    PREC f g l + sum_list l < ack (Suc (kf + kg)) (sum_list l)"
apply (unfold PREC_def)
apply (case_tac l)
 apply simp_all
 apply (blast intro: less_trans)
apply (erule ssubst) \<comment> \<open>get rid of the needless assumption\<close>
apply (induct_tac a)
 apply simp_all
 txt \<open>base case\<close>
 apply (blast intro: le_add1 [THEN le_imp_less_Suc, THEN ack_less_mono1] less_trans)
txt \<open>induction step\<close>
apply (rule Suc_leI [THEN le_less_trans])
 apply (rule le_refl [THEN add_le_mono, THEN le_less_trans])
  prefer 2
  apply (erule spec)
 apply (simp add: le_add2)
txt \<open>final part of the simplification\<close>
apply simp
apply (rule le_add2 [THEN ack_le_mono1, THEN le_less_trans])
apply (erule ack_less_mono2)
done

lemma PREC_case:
  "\<forall>l. f l < ack kf (sum_list l) ==>
    \<forall>l. g l < ack kg (sum_list l) ==>
    \<exists>k. \<forall>l. PREC f g l < ack k (sum_list l)"
by (metis le_less_trans [OF le_add1 PREC_case_aux] ack_add_bound2)

lemma ack_bounds_PRIMREC: "PRIMREC f ==> \<exists>k. \<forall>l. f l < ack k (sum_list l)"
apply (erule PRIMREC.induct)
    apply (blast intro: SC_case CONSTANT_case PROJ_case COMP_case PREC_case)+
done

theorem ack_not_PRIMREC:
  "\<not> PRIMREC (\<lambda>l. case l of [] => 0 | x # l' => ack x x)"
apply (rule notI)
apply (erule ack_bounds_PRIMREC [THEN exE])
apply (rule less_irrefl [THEN notE])
apply (drule_tac x = "[x]" in spec)
apply simp
done

end


(*<*)
(*
   Title:  Theory arith_hints.thy
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2013
*)
(*>*)
section \<open>Auxiliary arithmetic lemmas\<close>

theory arith_hints
imports Main
begin

lemma arith_mod_neq:
  assumes "a mod n \<noteq> b mod n"
  shows "a \<noteq> b"
  using assms by blast

lemma arith_mod_nzero:
  fixes i :: nat
  assumes "i < n" and "0 < i"
  shows "0 < (n * t + i) mod n"
  using assms by simp

lemma arith_mult_neq_nzero2:
  fixes i::nat
  assumes "i < n"
         and "0 < i"
  shows "n * t + i \<noteq> n * q"
using assms
by (metis arith_mult_neq_nzero1 add.commute)

lemma arith_mult_neq_nzero3:
  fixes i::nat
  assumes "i < n"
         and "0 < i"
  shows "n + n * t + i \<noteq> n * qc"
proof -
   from assms have sg1: "n *(Suc t) + i  \<noteq> n * qc"
     by (rule arith_mult_neq_nzero2)
   have sg2: "n + n * t + i = n *(Suc t) + i" by simp
   from sg1 and sg2  show ?thesis  by arith
qed

lemma arith_modZero1:
  "(t + n * t) mod Suc n = 0"
by (metis mod_mult_self1_is_0 mult_Suc)

lemma arith_modZero2:
  "Suc (n + (t + n * t)) mod Suc n = 0"
by (metis add_Suc_right add_Suc_shift mod_mult_self1_is_0 mult_Suc mult.commute)

lemma arith1:
  assumes h1:"Suc n * t = Suc n * q"
  shows "t = q"
using assms
by (metis mult_cancel2 mult.commute neq0_conv zero_less_Suc)

lemma arith2:
  fixes t n q :: "nat"
  assumes h1:"t + n * t = q + n * q"
  shows "t = q"
using assms
by (metis arith1 mult_Suc)

end


(*
  File:    Descartes_Sign_Rule.thy
  Author:  Manuel Eberl <manuel@pruvisto.org>

  Descartes' Rule of Signs, which relates the number of positive real roots of a polynomial
  with the number of sign changes in its coefficient list.
*)
section \<open>Sign changes and Descartes' Rule of Signs\<close>

theory Descartes_Sign_Rule
imports
  Complex_Main
  "HOL-Computational_Algebra.Polynomial"
begin

lemma filter_dropWhile:
  "filter (\<lambda>x. \<not>P x) (dropWhile P xs) = filter (\<lambda>x. \<not>P x) xs"
  by (induction xs) simp_all

subsection \<open>Polynomials\<close>

text\<open>
  A real polynomial whose leading and constant coefficients have opposite
  non-zero signs must have a positive root.
\<close>
lemma pos_root_exI:
  assumes "poly p 0 * lead_coeff p < (0 :: real)"
  obtains x where "x > 0" "poly p x = 0"
proof -
  have P: "\<exists>x>0. poly p x = (0::real)" if "lead_coeff p > 0" "poly p 0 < 0" for p
  proof -
    note that(1)
    also from poly_pinfty_gt_lc[OF \<open>lead_coeff p > 0\<close>] obtain x0
      where "\<And>x. x \<ge> x0 \<Longrightarrow> poly p x \<ge> lead_coeff p" by auto
    hence "poly p (max x0 1) \<ge> lead_coeff p" by auto
    finally have "poly p (max x0 1) > 0" .
    with that have "\<exists>x. x > 0 \<and> x < max x0 1 \<and> poly p x = 0"
      by (intro poly_IVT mult_neg_pos) auto
    thus "\<exists>x>0. poly p x = 0"  by auto
  qed

  show ?thesis
  proof (cases "lead_coeff p > 0")
    case True
    with assms have "poly p 0 < 0"
      by (auto simp: mult_less_0_iff)
    from P[OF True this] that show ?thesis
      by blast
  next
    case False
    from False assms have "poly (-p) 0 < 0"
      by (auto simp: mult_less_0_iff)
    moreover from assms have "p \<noteq> 0"
      by auto
    with False have "lead_coeff (-p) > 0"
      by (cases rule: linorder_cases[of "lead_coeff p" 0])
         (simp_all add:)
    ultimately show ?thesis using that P[of "-p"] by auto
  qed
qed

text \<open>
  Substitute $X$ with $aX$ in a polynomial $p(X)$. This turns all the $X - a$ factors in $p$
  into factors of the form $X - 1$.
\<close>
definition reduce_root where
  "reduce_root a p = pcompose p [:0, a:]"

lemma reduce_root_pCons:
  "reduce_root a (pCons c p) = pCons c (smult a (reduce_root a p))"
  by (simp add: reduce_root_def pcompose_pCons)

lemma reduce_root_nonzero [simp]:
  "a \<noteq> 0 \<Longrightarrow> p \<noteq> 0 \<Longrightarrow> reduce_root a p \<noteq> (0 :: 'a :: idom poly)"
  unfolding reduce_root_def using pcompose_eq_0[of p "[:0, a:]"]
  by auto

subsection \<open>List of partial sums\<close>

text \<open>
  We first define, for a given list, the list of accumulated partial sums from left to right:
  the list @{term "psums xs"} has as its $i$-th entry $\sum_{j=0}^i \mathrm{xs}_i$.
\<close>

fun psums where
  "psums [] = []"
| "psums [x] = [x]"
| "psums (x#y#xs) = x # psums ((x+y) # xs)"

lemma length_psums [simp]: "length (psums xs) = length xs"
  by (induction xs rule: psums.induct) simp_all

lemma psums_Cons:
  "psums (x#xs) = (x :: 'a :: semigroup_add) # map ((+) x) (psums xs)"
  by (induction xs rule: psums.induct) (simp_all add: algebra_simps)

lemma last_psums:
  "(xs :: 'a :: monoid_add list) \<noteq> [] \<Longrightarrow> last (psums xs) = sum_list xs"
  by (induction xs rule: psums.induct)
     (auto simp add: add.assoc [symmetric] psums_Cons o_def)

lemma psums_0_Cons [simp]:
  "psums (0#xs :: 'a :: monoid_add list) = 0 # psums xs"
  by (induction xs rule: psums.induct) (simp_all add: algebra_simps)

lemma map_uminus_psums:
  fixes xs :: "'a :: ab_group_add list"
  shows "map uminus (psums xs) = psums (map uminus xs)"
  by (induction xs rule: psums.induct) (simp_all)

lemma psums_replicate_0_append:
  "psums (replicate n (0 :: 'a :: monoid_add) @ xs) =
     replicate n 0 @ psums xs"
  by (induction n) (simp_all add: psums_Cons op_plus_0)

lemma psums_nth: "n < length xs \<Longrightarrow> psums xs ! n = (\<Sum>i\<le>n. xs ! i)"
proof (induction xs arbitrary: n rule: psums.induct[case_names Nil sng rec])
  case (rec x y xs n)
  show ?case
  proof (cases n)
    case (Suc m)
    from Suc have "psums (x # y # xs) ! n = psums ((x+y) # xs) ! m" by simp
    also from rec.prems Suc have "\<dots> = (\<Sum>i\<le>m. ((x+y) # xs) ! i)"
      by (intro rec.IH) simp_all
    also have "\<dots> = x + y + (\<Sum>i=1..m. (y#xs) ! i)"
      by (auto simp: atLeast0AtMost [symmetric] sum.atLeast_Suc_atMost[of 0])
    also have "(\<Sum>i=1..m. (y#xs) ! i) = (\<Sum>i=Suc 1..Suc m. (x#y#xs) ! i)"
      by (subst sum.shift_bounds_cl_Suc_ivl) simp
    also from Suc have "x + y + \<dots> = (\<Sum>i\<le>n. (x#y#xs) ! i)"
      by (auto simp: atLeast0AtMost [symmetric] sum.atLeast_Suc_atMost add_ac)
    finally show ?thesis .
  qed simp
qed simp_all

subsection \<open>Sign changes in a list\<close>

text \<open>
  Next, we define the number of sign changes in a sequence. Intuitively, this is the number
  of times that, when passing through the list, a sign change between one element and the next
  element occurs (while ignoring all zero entries).

  We implement this by filtering all zeros from the list of signs, removing all adjacent equal
  elements and taking the length of the resulting list minus one.
\<close>
definition sign_changes :: "('a :: {sgn,zero} list) \<Rightarrow> nat" where
  "sign_changes xs = length (remdups_adj (filter (\<lambda>x. x \<noteq> 0) (map sgn xs))) - 1"

lemma sign_changes_Nil [simp]: "sign_changes [] = 0"
  by (simp add: sign_changes_def)

lemma sign_changes_singleton [simp]: "sign_changes [x] = 0"
  by (simp add: sign_changes_def)

lemma sign_changes_cong:
  assumes "map sgn xs = map sgn ys"
  shows   "sign_changes xs = sign_changes ys"
  using assms unfolding sign_changes_def by simp

lemma sign_changes_Cons_ge: "sign_changes (x # xs) \<ge> sign_changes xs"
  unfolding sign_changes_def by (simp add: remdups_adj_Cons split: list.split)

lemma sign_changes_Cons_Cons_different:
  fixes x y :: "'a :: linordered_idom"
  assumes "x * y < 0"
  shows "sign_changes (x # y # xs) = 1 + sign_changes (y # xs)"
proof -
  from assms have "sgn x = -1 \<and> sgn y = 1 \<or> sgn x = 1 \<and> sgn y = -1"
    by (auto simp: mult_less_0_iff)
  thus ?thesis by (fastforce simp: sign_changes_def)
qed

lemma sign_changes_Cons_Cons_same:
  fixes x y :: "'a :: linordered_idom"
  shows "x * y > 0 \<Longrightarrow> sign_changes (x # y # xs) = sign_changes (y # xs)"
  by (subst (asm) zero_less_mult_iff) (fastforce simp: sign_changes_def)

lemma sign_changes_0_Cons [simp]:
  "sign_changes (0 # xs :: 'a :: idom_abs_sgn list) = sign_changes xs"
  by (simp add: sign_changes_def)

lemma sign_changes_two:
  fixes x y :: "'a :: linordered_idom"
  shows "sign_changes [x,y] =
           (if x > 0 \<and> y < 0 \<or> x < 0 \<and> y > 0 then 1 else 0)"
  by (auto simp: sgn_if sign_changes_def mult_less_0_iff)

lemma sign_changes_induct [case_names nil sing zero nonzero]:
  assumes "P []" "\<And>x. P [x]" "\<And>xs. P xs \<Longrightarrow> P (0#xs)"
          "\<And>x y xs. x \<noteq> 0 \<Longrightarrow> P ((x + y) # xs) \<Longrightarrow> P (x # y # xs)"
  shows   "P xs"
proof (induction "length xs" arbitrary: xs rule: less_induct)
  case (less xs)
  show ?case
  proof (cases xs rule: psums.cases)
    fix x y xs' assume "xs = x # y # xs'"
    with assms less show ?thesis by (cases "x = 0") auto
  qed (insert less assms, auto)
qed

lemma sign_changes_filter:
  fixes xs :: "'a :: linordered_idom list"
  shows "sign_changes (filter (\<lambda>x. x \<noteq> 0) xs) = sign_changes xs"
  by (simp add: sign_changes_def filter_map o_def sgn_0_0)

lemma sign_changes_Cons_Cons_0:
  fixes xs :: "'a :: linordered_idom list"
  shows "sign_changes (x # 0 # xs) = sign_changes (x # xs)"
  by (subst (1 2) sign_changes_filter [symmetric]) simp_all

lemma sign_changes_uminus:
  fixes xs :: "'a :: linordered_idom list"
  shows   "sign_changes (map uminus xs) = sign_changes xs"
proof -
  have "sign_changes (map uminus xs) =
          length (remdups_adj [x\<leftarrow>map sgn (map uminus xs) . x \<noteq> 0]) - 1"
   unfolding sign_changes_def ..
  also have "map sgn (map uminus xs) = map uminus (map sgn xs)"
    by (auto simp: sgn_minus)
  also have "remdups_adj (filter (\<lambda>x. x \<noteq> 0) \<dots>) =
                 map uminus (remdups_adj (filter (\<lambda>x. x \<noteq> 0) (map sgn xs)))"
    by (subst filter_map, subst remdups_adj_map_injective)
       (simp_all add: o_def)
  also have "length \<dots> - 1 = sign_changes xs" by (simp add: sign_changes_def)
  finally show ?thesis .
qed

lemma sign_changes_replicate: "sign_changes (replicate n x) = 0"
  by (simp add: sign_changes_def remdups_adj_replicate filter_replicate)

lemma sign_changes_decompose:
  assumes "x \<noteq> (0 :: 'a :: linordered_idom)"
  shows   "sign_changes (xs @ x # ys) =
             sign_changes (xs @ [x]) + sign_changes (x # ys)"
proof -
  have "sign_changes (xs @ x # ys) =
            length (remdups_adj ([x\<leftarrow>map sgn xs . x \<noteq> 0] @
                      sgn x # [x\<leftarrow>map sgn ys . x \<noteq> 0])) - 1"
    by (simp add: sgn_0_0 assms sign_changes_def)
  also have "\<dots> = sign_changes (xs @ [x]) + sign_changes (x # ys)"
    by (subst remdups_adj_append) (simp add: sign_changes_def assms sgn_0_0)
  finally show ?thesis .
qed

text \<open>
  If the first and the last entry of a list are non-zero, its number of sign changes is even
  if and only if the first and the last element have the same sign. This will be important
  later to establish the base case of Descartes' Rule. (if there are no positive roots,
  the number of sign changes is even)
\<close>
lemma even_sign_changes_iff:
  assumes "xs \<noteq> ([] :: 'a :: linordered_idom list)" "hd xs \<noteq> 0" "last xs \<noteq> 0"
  shows   "even (sign_changes xs) \<longleftrightarrow> sgn (hd xs) = sgn (last xs)"
using assms
proof (induction "length xs" arbitrary: xs rule: less_induct)
  case (less xs)
  show ?case
  proof (cases xs)
    case (Cons x xs')
    note x = this
    show ?thesis
    proof (cases xs')
      case (Cons y xs'')
      note y = this
      show ?thesis
      proof (rule linorder_cases[of "x*y" 0])
        assume xy: "x*y = 0"
        with x y less(1,3,4) show ?thesis by (auto simp: sign_changes_Cons_Cons_0)
      next
        assume xy: "x*y > 0"
        with less(1,4) show ?thesis
          by (auto simp add: x y sign_changes_Cons_Cons_same zero_less_mult_iff)
      next
        assume xy: "x*y < 0"
        moreover from xy have "sgn x = - sgn y" by (auto simp: mult_less_0_iff)
        moreover have "even (sign_changes (y # xs'')) \<longleftrightarrow>
                         sgn (hd (y # xs'')) = sgn (last (y # xs''))"
          using xy less.prems by (intro less) (auto simp: x y)
        moreover from xy less.prems
          have "sgn y = sgn (last xs) \<longleftrightarrow> -sgn y \<noteq> sgn (last xs)"
          by (auto simp: sgn_if)
        ultimately show ?thesis by (auto simp: sign_changes_Cons_Cons_different x y)
      qed
    qed (auto simp: x)
  qed (insert less.prems, simp_all)
qed

subsection \<open>Arthan's lemma\<close>

context
begin

text \<open>
  We first prove an auxiliary lemma that allows us to assume w.l.o.g. that the first element of
  the list is non-negative, similarly to what Arthan does in his proof.
\<close>
private lemma arthan_wlog [consumes 3, case_names nonneg lift]:
  fixes xs :: "'a :: linordered_idom list"
  assumes "xs \<noteq> []" "last xs \<noteq> 0" "x + y + sum_list xs = 0"
  assumes "\<And>x y xs. xs \<noteq> [] \<Longrightarrow> last xs \<noteq> 0 \<Longrightarrow>
               x + y + sum_list xs = 0 \<Longrightarrow> x \<ge> 0 \<Longrightarrow> P x y xs"
  assumes "\<And>x y xs. xs \<noteq> [] \<Longrightarrow> P x y xs \<Longrightarrow> P (-x) (-y) (map uminus xs)"
  shows   "P x y xs"
proof (cases "x \<ge> 0")
  assume x: "\<not>(x \<ge> 0)"
  from assms have "map uminus xs \<noteq> []" by simp
  moreover from x assms(1,2,3) have"P (-x) (-y) (map uminus xs)"
    using uminus_sum_list_map[of "\<lambda>x. x" xs, symmetric]
    by (intro assms) (auto simp: last_map algebra_simps o_def neg_eq_iff_add_eq_0)
  ultimately have "P (- (-x)) (- (-y)) (map uminus (map uminus xs))" by (rule assms)
  thus ?thesis by (simp add: o_def)
qed (simp_all add: assms)

text \<open>
  We now show that the $\alpha$ and $\beta$ in Arthan's proof have the necessary properties:
  their difference is non-negative and even.
\<close>
private lemma arthan_aux1:
  fixes xs :: "'a :: {linordered_idom} list"
  assumes "xs \<noteq> []" "last xs \<noteq> 0" "x + y + sum_list xs = 0"
  defines "v \<equiv> \<lambda>xs. int (sign_changes xs)"
  shows "v (x # y # xs) - v ((x + y) # xs) \<ge>
             v (psums (x # y # xs)) - v (psums ((x + y) # xs)) \<and>
         even (v (x # y # xs) - v ((x + y) # xs) -
                  (v (psums (x # y # xs)) - v (psums ((x + y) # xs))))"
using assms(1-3)
proof (induction rule: arthan_wlog)
  have uminus_v: "v (map uminus xs) = v xs" for xs by (simp add: v_def sign_changes_uminus)

  case (lift x y xs)
  note lift(2)
  also have "v (psums (x#y#xs)) - v (psums ((x+y)#xs)) =
                 v (psums (- x # - y # map uminus xs)) -
                 v (psums ((- x + - y) # map uminus xs))"
    by (subst (1 2) uminus_v [symmetric]) (simp add: map_uminus_psums)
  also have "v (x # y # xs) - v ((x + y) # xs) =
                 v (-x # -y # map uminus xs) - v ((-x + -y) # map uminus xs)"
    by (subst (1 2) uminus_v [symmetric]) simp
  finally show ?case .
next
  case (nonneg x y xs)
  define p where "p = (LEAST n. xs ! n \<noteq> 0)"
  define xs1 :: "'a list" where "xs1 = replicate p 0"
  define xs2 where "xs2 = drop (Suc p) xs"
  from nonneg have "xs ! (length xs - 1) \<noteq> 0" by (simp add: last_conv_nth)
  hence p_nz: "xs ! p \<noteq> 0" unfolding p_def by (rule LeastI)
  {
    fix q assume "q < p" hence "xs ! q = 0"
      using Least_le[of "\<lambda>n. xs ! n \<noteq> 0" q] unfolding p_def by force
  } note less_p_zero = this
  from Least_le[of "\<lambda>n. xs ! n \<noteq> 0" "length xs - 1"] nonneg
    have "p \<le> length xs - 1" unfolding p_def by (auto simp: last_conv_nth)
  with nonneg have p_less_length: "p < length xs" by (cases xs) simp_all

  from p_less_length less_p_zero have "take p xs = replicate p 0"
    by (subst list_eq_iff_nth_eq) auto
  with p_less_length have xs_decompose: "xs = xs1 @ xs ! p # xs2"
    unfolding xs1_def xs2_def
    by (subst append_take_drop_id [of p, symmetric],
        subst Cons_nth_drop_Suc) simp_all

  have v_decompose: "v (xs' @ xs) = v (xs' @ [xs ! p]) + v (xs ! p # xs2)" for xs'
  proof -
    have "xs' @ xs = (xs' @ xs1) @ xs ! p # xs2" by (subst xs_decompose) simp
    also have "v \<dots> = v (xs' @ [xs ! p]) + v (xs ! p # xs2)" unfolding v_def
      by (subst sign_changes_decompose[OF p_nz],
          subst (1 2 3 4) sign_changes_filter [symmetric]) (simp_all add: xs1_def)
    finally show ?thesis .
  qed

  have psums_decompose: "psums xs = replicate p 0 @ psums (xs!p # xs2)"
    by (subst xs_decompose) (simp add: xs1_def psums_replicate_0_append)
  have v_psums_decompose: "sign_changes (xs' @ psums xs) = sign_changes (xs' @ [xs!p]) +
         sign_changes (xs!p # map ((+) (xs!p)) (psums xs2))" for xs'
  proof -
    fix xs' :: "'a list"
    have "sign_changes (xs' @ psums xs) =
            sign_changes (xs' @ xs ! p # map ((+) (xs!p)) (psums xs2))"
      by (subst psums_decompose, subst (1 2) sign_changes_filter [symmetric])
         (simp_all add: psums_Cons)
    also have "\<dots> = sign_changes (xs' @ [xs!p]) +
                      sign_changes (xs!p # map ((+) (xs!p)) (psums xs2))"
      by (subst sign_changes_decompose[OF p_nz]) simp_all
    finally show "sign_changes (xs' @ psums xs) = \<dots>" .
  qed

  show ?case
  proof (cases "x > 0")
    assume "\<not>(x > 0)"
    with nonneg show ?thesis by (auto simp: v_def)
  next
    assume x: "x > 0"
    show ?thesis
    proof (rule linorder_cases[of y 0])
      assume y: "y > 0"
      from x and this have xy: "x + y > 0" by (rule add_pos_pos)
      with y have "sign_changes ((x + y) # xs) = sign_changes (y # xs)"
        by (intro sign_changes_cong) auto
      moreover have "sign_changes (x # psums ((x + y) # xs)) =
                       sign_changes (psums ((x+y) # xs))"
        using x xy by (subst (1 2) psums_Cons) (simp_all add: sign_changes_Cons_Cons_same)
      ultimately show ?thesis using x y
        by (simp add: v_def algebra_simps sign_changes_Cons_Cons_same)
    next
      assume y: "y = 0"
      with x show ?thesis
        by (simp add: v_def sign_changes_Cons_Cons_0 psums_Cons
                      o_def sign_changes_Cons_Cons_same)
    next
      assume y: "y < 0"
      with x have different: "x * y < 0" by (rule mult_pos_neg)
      show ?thesis
      proof (rule linorder_cases[of "x + y" 0])
        assume xy: "x + y < 0"
        with x have different': "x * (x + y) < 0" by (rule mult_pos_neg)
        have "(\<lambda>t. t + (x + y)) = ((+) (x + y))" by (rule ext) simp
        moreover from y xy have "sign_changes ((x+y) # xs) = sign_changes (y # xs)"
          by (intro sign_changes_cong) auto
        ultimately show ?thesis using xy different different' y
          by (simp add: v_def sign_changes_Cons_Cons_different psums_Cons o_def add_ac)
      next
        assume xy: "x + y = 0"
        show ?case
        proof (cases "xs ! p > 0")
          assume p: "xs ! p > 0"
          from p y have different': "y * xs ! p < 0" by (intro mult_neg_pos)
          with v_decompose[of "[x, y]"] v_decompose[of "[x+y]"] x xy p different different'
               v_psums_decompose[of "[x]"] v_psums_decompose[of "[]"]
          show ?thesis by (auto simp add: algebra_simps v_def sign_changes_Cons_Cons_0
                             sign_changes_Cons_Cons_different sign_changes_Cons_Cons_same)
        next
          assume "\<not>(xs ! p > 0)"
          with p_nz have p: "xs ! p < 0" by simp
          from p y have same: "y * xs ! p > 0" by (intro mult_neg_neg)
          from p x have different': "x * xs ! p < 0" by (intro mult_pos_neg)
          from v_decompose[of "[x, y]"] v_decompose[of "[x+y]"] xy different different' same
               v_psums_decompose[of "[x]"] v_psums_decompose[of "[]"]
          show ?thesis by (auto simp add: algebra_simps v_def sign_changes_Cons_Cons_0
                             sign_changes_Cons_Cons_different sign_changes_Cons_Cons_same)
        qed
      next
        assume xy: "x + y > 0"
        from x and this have same: "x * (x + y) > 0" by (rule mult_pos_pos)
        show ?case
        proof (cases "xs ! p > 0")
          assume p: "xs ! p > 0"
          from xy p have same': "(x + y) * xs ! p > 0" by (intro mult_pos_pos)
          from p y have different': "y * xs ! p < 0" by (intro mult_neg_pos)
          have "(\<lambda>t. t + (x + y)) = ((+) (x + y))" by (rule ext) simp
          with v_decompose[of "[x, y]"] v_decompose[of "[x+y]"] different different' same same'
          show ?thesis by (auto simp add: algebra_simps v_def psums_Cons o_def
                             sign_changes_Cons_Cons_different sign_changes_Cons_Cons_same)
        next
          assume "\<not>(xs ! p > 0)"
          with p_nz have p: "xs ! p < 0" by simp
          from xy p have different': "(x + y) * xs ! p < 0" by (rule mult_pos_neg)
          from y p have same': "y * xs ! p > 0" by (rule mult_neg_neg)
          have "(\<lambda>t. t + (x + y)) = ((+) (x + y))" by (rule ext) simp
          with v_decompose[of "[x, y]"] v_decompose[of "[x+y]"] different different' same same'
          show ?thesis by (auto simp add: algebra_simps v_def psums_Cons o_def
                              sign_changes_Cons_Cons_different sign_changes_Cons_Cons_same)
        qed
      qed
    qed
  qed
qed

text \<open>
  Now we can prove the main lemma of the proof by induction over the list with our specialised
  induction rule for @{term "sign_changes"}. It states that for a non-empty list whose last element
  is non-zero and whose sum is zero, the difference of the sign changes in the list and in the list
  of its partial sums is odd and positive.
\<close>
lemma arthan:
  fixes xs :: "'a :: linordered_idom list"
  assumes "xs \<noteq> []" "last xs \<noteq> 0" "sum_list xs = 0"
  shows   "sign_changes xs > sign_changes (psums xs) \<and>
           odd (sign_changes xs - sign_changes (psums xs))"
using assms
proof (induction xs rule: sign_changes_induct)
  case (nonzero x y xs)
  show ?case
  proof (cases "xs = []")
    case False
    define \<alpha> where "\<alpha> = int (sign_changes (x # y # xs)) - int (sign_changes ((x + y) # xs))"
    define \<beta> where "\<beta> = int (sign_changes (psums (x # y # xs))) - int (sign_changes (psums ((x+y) # xs)))"
    from nonzero False have "\<alpha> \<ge> \<beta> \<and> even (\<alpha> - \<beta>)" unfolding \<alpha>_def \<beta>_def
      by (intro arthan_aux1) auto
    from False and nonzero.prems have
       "sign_changes (psums ((x + y) # xs)) < sign_changes ((x + y) # xs) \<and>
        odd (sign_changes ((x + y) # xs) - sign_changes (psums ((x + y) # xs)))"
      by (intro nonzero.IH) (auto simp: add.assoc)
    with arthan_aux1[of xs x y] nonzero(4,5) False(1) show ?thesis by force
  qed (insert nonzero.prems, auto split: if_split_asm simp: sign_changes_two add_eq_0_iff)
qed (auto split: if_split_asm simp: add_eq_0_iff)

end

subsection \<open>Roots of a polynomial with a certain property\<close>

text \<open>
  The set of roots of a polynomial @{term "p"} that fulfil a given property @{term "P"}:
\<close>
definition "roots_with P p = {x. P x \<and> poly p x = 0}"

text \<open>
  The number of roots of a polynomial @{term "p"} with a given property @{term "P"}, where
  multiple roots are counted multiple times.
 \<close>
definition "count_roots_with P p = (\<Sum>x\<in>roots_with P p. order x p)"

abbreviation "pos_roots \<equiv> roots_with (\<lambda>x. x > 0)"
abbreviation "count_pos_roots \<equiv> count_roots_with (\<lambda>x. x > 0)"

lemma finite_roots_with [simp]:
  "(p :: 'a :: linordered_idom poly) \<noteq> 0 \<Longrightarrow> finite (roots_with P p)"
  by (rule finite_subset[OF _ poly_roots_finite[of p]]) (auto simp: roots_with_def)

lemma count_roots_with_times_root:
  assumes "p \<noteq> 0" "P (a :: 'a :: linordered_idom)"
  shows   "count_roots_with P ([:a, -1:] * p) = Suc (count_roots_with P p)"
proof -
  define q where "q = [:a, -1:] * p"
  from assms have a: "a \<in> roots_with P q" by (simp_all add: roots_with_def q_def)
  have q_nz: "q \<noteq> 0" unfolding q_def by (rule no_zero_divisors) (simp_all add: assms)

  have "count_roots_with P q = (\<Sum>x\<in>roots_with P q. order x q)" by (simp add: count_roots_with_def)
  also from a q_nz have "\<dots> = order a q + (\<Sum>x\<in>roots_with P q - {a}. order x q)"
    by (subst sum.remove) simp_all
  also have "order a q = order a [:a, -1:] + order a p" unfolding q_def
    by (subst order_mult[OF no_zero_divisors]) (simp_all add: assms)
  also have "order a [:a, -1:] = 1"
    by (subst order_smult [of "-1", symmetric])
       (insert order_power_n_n[of a 1], simp_all add: order_1)
  also have "(\<Sum>x\<in>roots_with P q - {a}. order x q) = (\<Sum>x\<in>roots_with P q - {a}. order x p)"
  proof (intro sum.cong refl)
    fix x assume x: "x \<in> roots_with P q - {a}"
    from assms have "order x q = order x [:a, -1:] + order x p" unfolding q_def
      by (subst order_mult[OF no_zero_divisors]) (simp_all add: assms)
    also from x have "order x [:a, -1:] = 0" by (intro order_0I) simp_all
    finally show "order x q = order x p" by simp
  qed
  also from a q_nz have "1 + order a p + (\<Sum>x\<in>roots_with P q - {a}. order x p) =
                           1 + (\<Sum>x\<in>roots_with P q. order x p)"
    by (subst add.assoc, subst sum.remove[symmetric]) simp_all
  also from q_nz have "(\<Sum>x\<in>roots_with P q. order x p) = (\<Sum>x\<in>roots_with P p. order x p)"
  proof (intro sum.mono_neutral_right)
    show "roots_with P p \<subseteq> roots_with P q"
      by (auto simp: roots_with_def q_def simp del: mult_pCons_left)
    show "\<forall>x\<in>roots_with P q - roots_with P p. order x p = 0"
      by (auto simp: roots_with_def q_def order_root simp del: mult_pCons_left)
  qed simp_all
  finally show ?thesis by (simp add: q_def count_roots_with_def)
qed

subsection \<open>Coefficient sign changes of a polynomial\<close>

abbreviation (input) "coeff_sign_changes f \<equiv> sign_changes (coeffs f)"

text \<open>
  We first show that when building a polynomial from a coefficient list, the coefficient sign
  sign changes of the resulting polynomial are the same as the same sign changes in the list.

  Note that constructing a polynomial from a list removes all trailing zeros.
\<close>
lemma sign_changes_coeff_sign_changes:
  assumes "Poly xs = (p :: 'a :: linordered_idom poly)"
  shows   "sign_changes xs = coeff_sign_changes p"
proof -
  have "coeffs p = coeffs (Poly xs)" by (subst assms) (rule refl)
  also have "\<dots> = strip_while ((=) 0) xs" by simp
  also have "filter ((\<noteq>) 0) \<dots> = filter ((\<noteq>) 0) xs" unfolding strip_while_def o_def
    by (subst rev_filter [symmetric], subst filter_dropWhile) (simp_all add: rev_filter)
  also have "sign_changes \<dots> = sign_changes xs" by (simp add: sign_changes_filter)
  finally show ?thesis by (simp add: sign_changes_filter)
qed

text \<open>
  By applying @{term "reduce_root a"}, we can assume w.l.o.g. that the root in
  question is 1, since applying root reduction does not change the number of
  sign changes.
\<close>
lemma coeff_sign_changes_reduce_root:
  assumes "a > (0 :: 'a :: linordered_idom)"
  shows   "coeff_sign_changes (reduce_root a p) = coeff_sign_changes p"
proof (intro sign_changes_cong, induction p)
  case (pCons c p)
  have "map sgn (coeffs (reduce_root a (pCons c p))) =
             cCons (sgn c) (map sgn (coeffs (reduce_root a p)))"
    using assms by (auto simp add: cCons_def sgn_0_0 sgn_mult reduce_root_pCons coeffs_smult)
  also note pCons.IH
  also have "cCons (sgn c) (map sgn (coeffs p)) = map sgn (coeffs (pCons c p))"
    using assms by (auto simp add: cCons_def sgn_0_0)
  finally show ?case .
qed (simp_all add: reduce_root_def)

text \<open>
  Multiplying a polynomial with a positive constant also does not change the number
  of sign changes. (in fact, any non-zero constant would also work, but the proof
  is slightly more difficult and positive constants suffice in our use case)
\<close>
lemma coeff_sign_changes_smult:
  assumes "a > (0 :: 'a :: linordered_idom)"
  shows   "coeff_sign_changes (smult a p) = coeff_sign_changes p"
  using assms by (auto intro!: sign_changes_cong simp: sgn_mult coeffs_smult)

context
begin

text \<open>
  We now show that a polynomial with an odd number of sign changes contains a
  positive root. We first assume that the constant coefficient is non-zero. Then it is
  clear that the polynomial's sign at 0 will be the sign of the constant coefficient, whereas
  the polynomial's sign for sufficiently large inputs will be the sign of the leading coefficient.

  Moreover, we have shown before that in a list with an odd number of sign changes and
  non-zero initial and last coefficients, the initial coefficient and the last coefficient have
  opposite and non-zero signs. Then, the polynomial obviously has a positive root.
\<close>
private lemma odd_coeff_sign_changes_imp_pos_roots_aux:
  assumes [simp]: "p \<noteq> (0 :: real poly)" "poly p 0 \<noteq> 0"
  assumes "odd (coeff_sign_changes p)"
  obtains x where "x > 0" "poly p x = 0"
proof -
  from \<open>poly p 0 \<noteq> 0\<close>
  have [simp]: "hd (coeffs p) \<noteq> 0"
    by (induct p) auto
  from assms have  "\<not> even (coeff_sign_changes p)"
    by blast
  also have "even (coeff_sign_changes p) \<longleftrightarrow> sgn (hd (coeffs p)) = sgn (lead_coeff p)"
    by (auto simp add: even_sign_changes_iff last_coeffs_eq_coeff_degree)
  finally have "sgn (hd (coeffs p)) * sgn (lead_coeff p) < 0"
    by (auto simp: sgn_if split: if_split_asm)
  also from \<open>p \<noteq> 0\<close> have "hd (coeffs p) = poly p 0" by (induction p) auto
  finally have "poly p 0 * lead_coeff p < 0" by (auto simp: mult_less_0_iff)

  from pos_root_exI[OF this] that show ?thesis by blast
qed

text \<open>
  We can now show the statement without the restriction to a non-zero constant coefficient.
  We can do this by simply factoring $p$ into the form $p \cdot x^n$, where $n$ is chosen as
  large as possible. This corresponds to stripping all initial zeros of the coefficient list,
  which obviously changes neither the existence of positive roots nor the number of coefficient
  sign changes.
\<close>
lemma odd_coeff_sign_changes_imp_pos_roots:
  assumes "p \<noteq> (0 :: real poly)"
  assumes "odd (coeff_sign_changes p)"
  obtains x where "x > 0" "poly p x = 0"
proof -
  define s where "s = sgn (lead_coeff p)"
  define n where "n = order 0 p"
  define r where "r = p div [:0, 1:] ^ n"
  have p: "p = [:0, 1:] ^ n * r" unfolding r_def n_def
    using order_1[of 0 p] by (simp del: mult_pCons_left)
  from assms p have r_nz: "r \<noteq> 0" by auto

  obtain x where "x > 0" "poly r x = 0"
  proof (rule odd_coeff_sign_changes_imp_pos_roots_aux)
    show "r \<noteq> 0" by fact
    have "order 0 p = order 0 p + order 0 r"
      by (subst p, insert order_power_n_n[of "0::real" n] r_nz)
         (simp del: mult_pCons_left add: order_mult n_def)
    hence "order 0 r = 0" by simp
    with r_nz show nz: "poly r 0 \<noteq> 0" by (simp add: order_root)

    note \<open>odd (coeff_sign_changes p)\<close>
    also have "p = [:0, 1:] ^ n * r" by (simp add: p)
    also have "[:0, 1:] ^ n = monom 1 n"
      by (induction n) (simp_all add: monom_Suc monom_0)
    also have "coeffs (monom 1 n * r) = replicate n 0 @ coeffs r"
      by (induction n) (simp_all add: monom_Suc cCons_def r_nz monom_0)
    also have "sign_changes \<dots> = coeff_sign_changes r"
      by (subst (1 2) sign_changes_filter [symmetric]) simp
    finally show "odd (coeff_sign_changes r)" .
  qed
  thus ?thesis by (intro that[of x]) (simp_all add: p)
qed

end

subsection \<open>Proof of Descartes' sign rule\<close>

text \<open>
  For a polynomial $p(X) = a_0 + \ldots + a_n X^n$, we have
  $[X^i] (1-X)p(X) = (\sum\limits_{j=0}^i a_j)$.
\<close>
lemma coeff_poly_times_one_minus_x:
  fixes g :: "'a :: linordered_idom poly"
  shows "coeff g n = (\<Sum>i\<le>n. coeff (g * [:1, -1:]) i)"
  by (induction n) simp_all

text \<open>
  We apply the previous lemma to the coefficient list of a polynomial and show:
  given a polynomial $p(X)$ and $q(X) = (1 - X)p(X)$, the coefficient list of $p(X)$ is the
  list of partial sums of the coefficient list of $q(X)$.
\<close>
lemma Poly_times_one_minus_x_eq_psums:
  fixes xs :: "'a :: linordered_idom list"
  assumes [simp]: "length xs = length ys"
  assumes "Poly xs = Poly ys * [:1, -1:]"
  shows   "ys = psums xs"
proof (rule nth_equalityI; safe?)
  fix i assume i: "i < length ys"
  hence "ys ! i = coeff (Poly ys) i"
    by (simp add: nth_default_def)
  also from coeff_poly_times_one_minus_x[of "Poly ys" i] assms
    have "\<dots> = (\<Sum>j\<le>i. coeff (Poly xs) j)" by simp
    also from i have "\<dots> = psums xs ! i"
      by (auto simp: nth_default_def psums_nth)
  finally show "ys ! i = psums xs ! i" .
qed simp_all

text \<open>
  We can now apply our main lemma on the sign changes in lists to the coefficient lists of
  a nonzero polynomial $p(X)$ and $(1-X)p(X)$: the difference of the changes in the
  coefficient lists is odd and positive.
\<close>
lemma sign_changes_poly_times_one_minus_x:
  fixes g :: "'a :: linordered_idom poly" and a :: 'a
  assumes nz: "g \<noteq> 0"
  defines "v \<equiv> coeff_sign_changes"
  shows "v ([:1, -1:] * g) - v g > 0 \<and> odd (v ([:1, -1:] * g) - v g)"
proof -
  define xs where "xs = coeffs ([:1, -1:] * g)"
  define ys where "ys = coeffs g @ [0]"
  have ys: "ys = psums xs"
  proof (rule Poly_times_one_minus_x_eq_psums)
    show "length xs = length ys" unfolding xs_def ys_def
      by (simp add: length_coeffs nz degree_mult_eq no_zero_divisors del: mult_pCons_left)
    show "Poly xs = Poly ys * [:1, - 1:]" unfolding xs_def ys_def
      by (simp only: Poly_snoc Poly_coeffs) simp
  qed
  have "sign_changes (psums xs) < sign_changes xs \<and>
        odd (sign_changes xs - sign_changes (psums xs))"
  proof (rule arthan)
    show "xs \<noteq> []"
      by (auto simp: xs_def nz simp del: mult_pCons_left)
    then show "sum_list xs = 0" by (simp add: last_psums [symmetric] ys [symmetric] ys_def)
    show "last xs \<noteq> 0"
      by (auto simp: xs_def nz last_coeffs_eq_coeff_degree simp del: mult_pCons_left)
  qed
  with ys have "sign_changes ys < sign_changes xs \<and>
                odd (sign_changes xs - sign_changes ys)" by simp
  also have "sign_changes xs = v ([:1, -1:] * g)" unfolding v_def
    by (intro sign_changes_coeff_sign_changes) (simp_all add: xs_def)
  also have "sign_changes ys = v g" unfolding v_def
    by (intro sign_changes_coeff_sign_changes) (simp_all add: ys_def Poly_snoc)
  finally show ?thesis by simp
qed

text \<open>
  We can now lift the previous lemma to the case of $p(X)$ and $(a-X)p(X)$ by substituting $X$
  with $aX$, yielding the polynomials $p(aX)$ and $a \cdot (1-X) \cdot p(aX)$.
\<close>
lemma sign_changes_poly_times_root_minus_x:
  fixes g :: "'a :: linordered_idom poly" and a :: 'a
  assumes nz: "g \<noteq> 0" and pos: "a > 0"
  defines "v \<equiv> coeff_sign_changes"
  shows "v ([:a, -1:] * g) - v g > 0 \<and> odd (v ([:a, -1:] * g) - v g)"
proof -
  have "0 < v ([:1, - 1:] * reduce_root a g) - v (reduce_root a g) \<and>
            odd (v ([:1, - 1:] * reduce_root a g) - v (reduce_root a g))"
    using nz pos unfolding v_def by (intro sign_changes_poly_times_one_minus_x) simp_all
  also have "v ([:1, -1:] * reduce_root a g) = v (smult a ([:1, -1:] * reduce_root a g))"
    unfolding v_def by (simp add: coeff_sign_changes_smult pos)
  also have "smult a ([:1, -1:] * reduce_root a g) = [:a:] * [:1, -1:] * reduce_root a g"
    by (subst mult.assoc) simp
  also have "[:a:] * [:1, -1:] = reduce_root a [:a, -1:]"
    by (simp add: reduce_root_def pcompose_pCons)
  also have "\<dots> * reduce_root a g = reduce_root a ([:a, -1:] * g)"
    unfolding reduce_root_def by (simp only: pcompose_mult)
  also have "v \<dots> = v ([:a, -1:] * g)" by (simp add: v_def coeff_sign_changes_reduce_root pos)
  also have "v (reduce_root a g) = v g" by (simp add: v_def coeff_sign_changes_reduce_root pos)
  finally show ?thesis .
qed

text \<open>
  Finally, the difference of the number of coefficient sign changes and the number of
  positive roots is non-negative and even. This follows straightforwardly by induction
  over the roots.
\<close>
lemma descartes_sign_rule_aux:
  fixes p :: "real poly"
  assumes "p \<noteq> 0"
  shows   "coeff_sign_changes p \<ge> count_pos_roots p \<and>
           even (coeff_sign_changes p - count_pos_roots p)"
using assms
proof (induction p rule: poly_root_induct[where P = "\<lambda>a. a > 0"])
  case (root a p)
  define q where "q = [:a, -1:] * p"
  from root.prems have p: "p \<noteq> 0" by auto
  with root p sign_changes_poly_times_root_minus_x[of p a]
       count_roots_with_times_root[of p "\<lambda>x. x > 0" a] show ?case by (fold q_def) fastforce
next
  case (no_roots p)
  from no_roots have "pos_roots p = {}" by (auto simp: roots_with_def)
  hence [simp]: "count_pos_roots p = 0" by (simp add: count_roots_with_def)
  thus ?case using no_roots \<open>p \<noteq> 0\<close> odd_coeff_sign_changes_imp_pos_roots[of p]
    by (auto simp: roots_with_def)
qed simp_all

text \<open>
  The main theorem is then an obvious consequence
\<close>
theorem descartes_sign_rule:
  fixes p :: "real poly"
  assumes "p \<noteq> 0"
  shows "\<exists>d. even d \<and> coeff_sign_changes p = count_pos_roots p + d"
proof
  define d where "d = coeff_sign_changes p - count_pos_roots p"
  show "even d \<and> coeff_sign_changes p = count_pos_roots p + d"
    unfolding d_def using descartes_sign_rule_aux[OF assms] by auto
qed

end


(*<*)
theory Tree imports Main begin
(*>*)

text\<open>\noindent
Define the datatype of \rmindex{binary trees}:
\<close>

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"(*<*)

primrec mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node l x r) = Node (mirror r) x (mirror l)"(*>*)

text\<open>\noindent
Define a function \<^term>\<open>mirror\<close> that mirrors a binary tree
by swapping subtrees recursively. Prove
\<close>

lemma mirror_mirror: "mirror(mirror t) = t"
(*<*)
apply(induct_tac t)
by(auto)

primrec flatten :: "'a tree => 'a list" where
"flatten Tip = []" |
"flatten (Node l x r) = flatten l @ [x] @ flatten r"
(*>*)

text\<open>\noindent
Define a function \<^term>\<open>flatten\<close> that flattens a tree into a list
by traversing it in infix order. Prove
\<close>

lemma "flatten(mirror t) = rev(flatten t)"
(*<*)
apply(induct_tac t)
by(auto)

end
(*>*)


(* Title:      Matrix Relation Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Matrix Relation Algebras\<close>

text \<open>
This theory gives matrix models of Stone relation algebras and more general structures.
We consider only square matrices.
The main result is that matrices over Stone relation algebras form a Stone relation algebra.

We use the monoid structure underlying semilattices to provide finite sums, which are necessary for defining the composition of two matrices.
See \cite{ArmstrongFosterStruthWeber2016,ArmstrongGomesStruthWeber2016} for similar liftings to matrices for semirings and relation algebras.
A technical difference is that those theories are mostly based on semirings whereas our hierarchy is mostly based on lattices (and our semirings directly inherit from semilattices).

Relation algebras have both a semiring and a lattice structure such that semiring addition and lattice join coincide.
In particular, finite sums and finite suprema coincide.
Isabelle/HOL has separate theories for semirings and lattices, based on separate addition and join operations and different operations for finite sums and finite suprema.
Reusing results from both theories is beneficial for relation algebras, but not always easy to realise.
\<close>

theory Matrix_Relation_Algebras

imports Relation_Algebras

begin

subsection \<open>Finite Suprema\<close>

text \<open>
We consider finite suprema in idempotent semirings and Stone relation algebras.
We mostly use the first of the following notations, which denotes the supremum of expressions \<open>t(x)\<close> over all \<open>x\<close> from the type of \<open>x\<close>.
For finite types, this is implemented in Isabelle/HOL as the repeated application of binary suprema.
\<close>

syntax
  "_sum_sup_monoid" :: "idt \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Squnion>\<^sub>_ _)" [0,10] 10)
  "_sum_sup_monoid_bounded" :: "idt \<Rightarrow> 'b set \<Rightarrow> 'a::bounded_semilattice_sup_bot \<Rightarrow> 'a" ("(\<Squnion>\<^bsub>_\<in>_\<^esub> _)" [0,51,10] 10)
translations
  "\<Squnion>\<^sub>x t" => "XCONST sup_monoid.sum (\<lambda>x . t) { x . CONST True }"
  "\<Squnion>\<^bsub>x\<in>X\<^esub> t" => "XCONST sup_monoid.sum (\<lambda>x . t) X"

context idempotent_semiring
begin

text \<open>
The following induction principles are useful for comparing two suprema.
The first principle works because types are not empty.
\<close>

lemma one_sup_induct [case_names one sup]:
  fixes f g :: "'b::finite \<Rightarrow> 'a"
  assumes one: "\<And>i . P (f i) (g i)"
      and sup: "\<And>j I . j \<notin> I \<Longrightarrow> P (\<Squnion>\<^bsub>i\<in>I\<^esub> f i) (\<Squnion>\<^bsub>i\<in>I\<^esub> g i) \<Longrightarrow> P (f j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> f i)) (g j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> g i))"
    shows "P (\<Squnion>\<^sub>k f k) (\<Squnion>\<^sub>k g k)"
proof -
  let ?X = "{ k::'b . True }"
  have "finite ?X" and "?X \<noteq> {}"
    by auto
  thus ?thesis
  proof (induct rule: finite_ne_induct)
    case (singleton i) thus ?case
      using one by simp
  next
    case (insert j I) thus ?case
      using sup by simp
  qed
qed

lemma bot_sup_induct [case_names bot sup]:
  fixes f g :: "'b::finite \<Rightarrow> 'a"
  assumes bot: "P bot bot"
      and sup: "\<And>j I . j \<notin> I \<Longrightarrow> P (\<Squnion>\<^bsub>i\<in>I\<^esub> f i) (\<Squnion>\<^bsub>i\<in>I\<^esub> g i) \<Longrightarrow> P (f j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> f i)) (g j \<squnion> (\<Squnion>\<^bsub>i\<in>I\<^esub> g i))"
    shows "P (\<Squnion>\<^sub>k f k) (\<Squnion>\<^sub>k g k)"
  apply (induct rule: one_sup_induct)
  using bot sup apply fastforce
  using sup by blast

text \<open>
Now many properties of finite suprema follow by simple applications of the above induction rules.
In particular, we show distributivity of composition, isotonicity and the upper-bound property.
\<close>

lemma comp_right_dist_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<Squnion>\<^sub>k f k * x) = (\<Squnion>\<^sub>k f k) * x"
proof (induct rule: one_sup_induct)
  case one show ?case
    by simp
next
  case (sup j I) thus ?case
    using mult_right_dist_sup by auto
qed

lemma comp_left_dist_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<Squnion>\<^sub>k x * f k) = x * (\<Squnion>\<^sub>k f k)"
proof (induct rule: one_sup_induct)
  case one show ?case
    by simp
next
  case (sup j I) thus ?case
    by (simp add: mult_left_dist_sup)
qed

lemma leq_sum:
  fixes f g :: "'b::finite \<Rightarrow> 'a"
  shows "(\<forall>k . f k \<le> g k) \<Longrightarrow> (\<Squnion>\<^sub>k f k) \<le> (\<Squnion>\<^sub>k g k)"
proof (induct rule: one_sup_induct)
  case one thus ?case
    by simp
next
  case (sup j I) thus ?case
    using sup_mono by blast
qed

lemma ub_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "f i \<le> (\<Squnion>\<^sub>k f k)"
proof -
  have "i \<in> { k . True }"
    by simp
  thus "f i \<le> (\<Squnion>\<^sub>k f (k::'b))"
    by (metis finite_code sup_monoid.sum.insert sup_ge1 mk_disjoint_insert)
qed

lemma lub_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  assumes "\<forall>k . f k \<le> x"
    shows "(\<Squnion>\<^sub>k f k) \<le> x"
proof (induct rule: one_sup_induct)
  case one show ?case
    by (simp add: assms)
next
  case (sup j I) thus ?case
    using assms le_supI by blast
qed

lemma lub_sum_iff:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<forall>k . f k \<le> x) \<longleftrightarrow> (\<Squnion>\<^sub>k f k) \<le> x"
  using order.trans ub_sum lub_sum by blast

end

context stone_relation_algebra
begin

text \<open>
In Stone relation algebras, we can also show that converse,  double complement and meet distribute over finite suprema.
\<close>

lemma conv_dist_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<Squnion>\<^sub>k (f k)\<^sup>T) = (\<Squnion>\<^sub>k f k)\<^sup>T"
proof (induct rule: one_sup_induct)
  case one show ?case
    by simp
next
  case (sup j I) thus ?case
    by (simp add: conv_dist_sup)
qed

lemma pp_dist_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<Squnion>\<^sub>k --f k) = --(\<Squnion>\<^sub>k f k)"
proof (induct rule: one_sup_induct)
  case one show ?case
    by simp
next
  case (sup j I) thus ?case
    by simp
qed

lemma inf_right_dist_sum:
  fixes f :: "'b::finite \<Rightarrow> 'a"
  shows "(\<Squnion>\<^sub>k f k \<sqinter> x) = (\<Squnion>\<^sub>k f k) \<sqinter> x"
  by (rule comp_inf.comp_right_dist_sum)

end

subsection \<open>Square Matrices\<close>

text \<open>
Because our semiring and relation algebra type classes only work for homogeneous relations, we only look at square matrices.
\<close>

type_synonym ('a,'b) square = "'a \<times> 'a \<Rightarrow> 'b"

text \<open>
We use standard matrix operations.
The Stone algebra structure is lifted componentwise.
Composition is matrix multiplication using given composition and supremum operations.
Its unit lifts given zero and one elements into an identity matrix.
Converse is matrix transpose with an additional componentwise transpose.
\<close>

definition less_eq_matrix :: "('a,'b::ord) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"                                           (infix "\<preceq>" 50)   where "f \<preceq> g = (\<forall>e . f e \<le> g e)"
definition less_matrix    :: "('a,'b::ord) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"                                           (infix "\<prec>" 50)   where "f \<prec> g = (f \<preceq> g \<and> \<not> g \<preceq> f)"
definition sup_matrix     :: "('a,'b::sup) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                                 (infixl "\<oplus>" 65)  where "f \<oplus> g = (\<lambda>e . f e \<squnion> g e)"
definition inf_matrix     :: "('a,'b::inf) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                                 (infixl "\<otimes>" 67)  where "f \<otimes> g = (\<lambda>e . f e \<sqinter> g e)"
definition minus_matrix   :: "('a,'b::{uminus,inf}) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                        (infixl "\<ominus>" 65)  where "f \<ominus> g = (\<lambda>e . f e \<sqinter> -g e)"
definition implies_matrix :: "('a,'b::implies) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square"                             (infixl "\<oslash>" 65)  where "f \<oslash> g = (\<lambda>e . f e \<leadsto> g e)"
definition times_matrix   :: "('a,'b::{times,bounded_semilattice_sup_bot}) square \<Rightarrow> ('a,'b) square \<Rightarrow> ('a,'b) square" (infixl "\<odot>" 70)  where "f \<odot> g = (\<lambda>(i,j) . \<Squnion>\<^sub>k f (i,k) * g (k,j))"
definition uminus_matrix  :: "('a,'b::uminus) square \<Rightarrow> ('a,'b) square"                                                ("\<ominus> _" [80] 80)  where "\<ominus>f    = (\<lambda>e . -f e)"
definition conv_matrix    :: "('a,'b::conv) square \<Rightarrow> ('a,'b) square"                                                  ("_\<^sup>t" [100] 100) where "f\<^sup>t      = (\<lambda>(i,j) . (f (j,i))\<^sup>T)"
definition bot_matrix     :: "('a,'b::bot) square"                                                                     ("mbot")         where "mbot   = (\<lambda>e . bot)"
definition top_matrix     :: "('a,'b::top) square"                                                                     ("mtop")         where "mtop   = (\<lambda>e . top)"
definition one_matrix     :: "('a,'b::{one,bot}) square"                                                               ("mone")         where "mone   = (\<lambda>(i,j) . if i = j then 1 else bot)"

subsection \<open>Stone Algebras\<close>

text \<open>
We first lift the Stone algebra structure.
Because all operations are componentwise, this also works for infinite matrices.
\<close>

interpretation matrix_order: order where less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::order) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
  apply unfold_locales
  apply (simp add: less_matrix_def)
  apply (simp add: less_eq_matrix_def)
  apply (meson less_eq_matrix_def order_trans)
  by (meson less_eq_matrix_def antisym ext)

interpretation matrix_semilattice_sup: semilattice_sup where sup = sup_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::semilattice_sup) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
  apply unfold_locales
  apply (simp add: sup_matrix_def less_eq_matrix_def)
  apply (simp add: sup_matrix_def less_eq_matrix_def)
  by (simp add: sup_matrix_def less_eq_matrix_def)

interpretation matrix_semilattice_inf: semilattice_inf where inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::semilattice_inf) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
  apply unfold_locales
  apply (simp add: inf_matrix_def less_eq_matrix_def)
  apply (simp add: inf_matrix_def less_eq_matrix_def)
  by (simp add: inf_matrix_def less_eq_matrix_def)

interpretation matrix_bounded_semilattice_sup_bot: bounded_semilattice_sup_bot where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_semilattice_sup_bot) square"
  apply unfold_locales
  by (simp add: bot_matrix_def less_eq_matrix_def)

interpretation matrix_bounded_semilattice_inf_top: bounded_semilattice_inf_top where inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and top = "top_matrix :: ('a,'b::bounded_semilattice_inf_top) square"
  apply unfold_locales
  by (simp add: less_eq_matrix_def top_matrix_def)

interpretation matrix_lattice: lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::lattice) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool" ..

interpretation matrix_distrib_lattice: distrib_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = "less_matrix :: ('a,'b::distrib_lattice) square \<Rightarrow> ('a,'b) square \<Rightarrow> bool"
  apply unfold_locales
  by (simp add: sup_inf_distrib1 sup_matrix_def inf_matrix_def)

interpretation matrix_bounded_lattice: bounded_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_lattice) square" and top = top_matrix ..

interpretation matrix_bounded_distrib_lattice: bounded_distrib_lattice where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::bounded_distrib_lattice) square" and top = top_matrix ..

interpretation matrix_p_algebra: p_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::p_algebra) square" and top = top_matrix and uminus = uminus_matrix
  apply unfold_locales
  apply (unfold inf_matrix_def bot_matrix_def less_eq_matrix_def uminus_matrix_def)
  by (meson pseudo_complement)

interpretation matrix_pd_algebra: pd_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::pd_algebra) square" and top = top_matrix and uminus = uminus_matrix ..

text \<open>
In particular, matrices over Stone algebras form a Stone algebra.
\<close>

interpretation matrix_stone_algebra: stone_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::stone_algebra) square" and top = top_matrix and uminus = uminus_matrix
  by unfold_locales (simp add: sup_matrix_def uminus_matrix_def top_matrix_def)

interpretation matrix_heyting_stone_algebra: heyting_stone_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::heyting_stone_algebra) square" and top = top_matrix and uminus = uminus_matrix and implies = implies_matrix
  apply unfold_locales
  apply (unfold inf_matrix_def sup_matrix_def bot_matrix_def top_matrix_def less_eq_matrix_def uminus_matrix_def implies_matrix_def)
  apply (simp add: implies_galois)
  apply (simp add: uminus_eq)
  by simp

interpretation matrix_boolean_algebra: boolean_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a,'b::boolean_algebra) square" and top = top_matrix and uminus = uminus_matrix and minus = minus_matrix
  apply unfold_locales
  apply simp
  apply (simp add: sup_matrix_def uminus_matrix_def top_matrix_def)
  by (simp add: inf_matrix_def uminus_matrix_def minus_matrix_def)

subsection \<open>Semirings\<close>

text \<open>
Next, we lift the semiring structure.
Because of composition, this requires a restriction to finite matrices.
\<close>

interpretation matrix_monoid: monoid_mult where times = times_matrix and one = "one_matrix :: ('a::finite,'b::idempotent_semiring) square"
proof
  fix f g h :: "('a,'b) square"
  show "(f \<odot> g) \<odot> h = f \<odot> (g \<odot> h)"
  proof (rule ext, rule prod_cases)
    fix i j
    have "((f \<odot> g) \<odot> h) (i,j) = (\<Squnion>\<^sub>l (f \<odot> g) (i,l) * h (l,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>l (\<Squnion>\<^sub>k f (i,k) * g (k,l)) * h (l,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k (f (i,k) * g (k,l)) * h (l,j))"
      by (metis (no_types) comp_right_dist_sum)
    also have "... = (\<Squnion>\<^sub>l \<Squnion>\<^sub>k f (i,k) * (g (k,l) * h (l,j)))"
      by (simp add: mult.assoc)
    also have "... = (\<Squnion>\<^sub>k \<Squnion>\<^sub>l f (i,k) * (g (k,l) * h (l,j)))"
      using sup_monoid.sum.swap by auto
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (\<Squnion>\<^sub>l g (k,l) * h (l,j)))"
      by (metis (no_types) comp_left_dist_sum)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<odot> h) (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (f \<odot> (g \<odot> h)) (i,j)"
      by (simp add: times_matrix_def)
    finally show "((f \<odot> g) \<odot> h) (i,j) = (f \<odot> (g \<odot> h)) (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "mone \<odot> f = f"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(mone \<odot> f) (i,j) = (\<Squnion>\<^sub>k mone (i,k) * f (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k (if i = k then 1 else bot) * f (k,j))"
      by (simp add: one_matrix_def)
    also have "... = (\<Squnion>\<^sub>k if i = k then 1 * f (k,j) else bot * f (k,j))"
      by (metis (full_types, hide_lams))
    also have "... = (\<Squnion>\<^sub>k if i = k then f (k,j) else bot)"
      by (meson mult_left_one mult_left_zero)
    also have "... = f (i,j)"
      by simp
    finally show "(mone \<odot> f) (i,j) = f (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "f \<odot> mone = f"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(f \<odot> mone) (i,j) = (\<Squnion>\<^sub>k f (i,k) * mone (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (if k = j then 1 else bot))"
      by (simp add: one_matrix_def)
    also have "... = (\<Squnion>\<^sub>k if k = j then f (i,k) * 1 else f (i,k) * bot)"
      by (metis (full_types, hide_lams))
    also have "... = (\<Squnion>\<^sub>k if k = j then f (i,k) else bot)"
      by (meson mult.right_neutral semiring.mult_zero_right)
    also have "... = f (i,j)"
      by simp
    finally show "(f \<odot> mone) (i,j) = f (i,j)"
      .
  qed
qed

interpretation matrix_idempotent_semiring: idempotent_semiring where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::idempotent_semiring) square" and one = one_matrix and times = times_matrix
proof
  fix f g h :: "('a,'b) square"
  show "f \<odot> g \<oplus> f \<odot> h \<preceq> f \<odot> (g \<oplus> h)"
  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
    fix i j
    have "(f \<odot> g \<oplus> f \<odot> h) (i,j) = (f \<odot> g) (i,j) \<squnion> (f \<odot> h) (i,j)"
      by (simp add: sup_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<squnion> (\<Squnion>\<^sub>k f (i,k) * h (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<squnion> f (i,k) * h (k,j))"
      by (simp add: sup_monoid.sum.distrib)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<squnion> h (k,j)))"
      by (simp add: mult_left_dist_sup)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<oplus> h) (k,j))"
      by (simp add: sup_matrix_def)
    also have "... = (f \<odot> (g \<oplus> h)) (i,j)"
      by (simp add: times_matrix_def)
    finally show "(f \<odot> g \<oplus> f \<odot> h) (i,j) \<le> (f \<odot> (g \<oplus> h)) (i,j)"
      by simp
  qed
next
  fix f g h :: "('a,'b) square"
  show "(f \<oplus> g) \<odot> h = f \<odot> h \<oplus> g \<odot> h"
  proof (rule ext, rule prod_cases)
    fix i j
    have "((f \<oplus> g) \<odot> h) (i,j) = (\<Squnion>\<^sub>k (f \<oplus> g) (i,k) * h (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k (f (i,k) \<squnion> g (i,k)) * h (k,j))"
      by (simp add: sup_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * h (k,j) \<squnion> g (i,k) * h (k,j))"
      by (meson mult_right_dist_sup)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * h (k,j)) \<squnion> (\<Squnion>\<^sub>k g (i,k) * h (k,j))"
      by (simp add: sup_monoid.sum.distrib)
    also have "... = (f \<odot> h) (i,j) \<squnion> (g \<odot> h) (i,j)"
      by (simp add: times_matrix_def)
    also have "... = (f \<odot> h \<oplus> g \<odot> h) (i,j)"
      by (simp add: sup_matrix_def)
    finally show "((f \<oplus> g) \<odot> h) (i,j) = (f \<odot> h \<oplus> g \<odot> h) (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "mbot \<odot> f = mbot"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(mbot \<odot> f) (i,j) = (\<Squnion>\<^sub>k mbot (i,k) * f (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k bot * f (k,j))"
      by (simp add: bot_matrix_def)
    also have "... = bot"
      by simp
    also have "... = mbot (i,j)"
      by (simp add: bot_matrix_def)
    finally show "(mbot \<odot> f) (i,j) = mbot (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "mone \<odot> f = f"
    by simp
next
  fix f :: "('a,'b) square"
  show "f \<preceq> f \<odot> mone"
    by simp
next
  fix f g h :: "('a,'b) square"
  show "f \<odot> (g \<oplus> h) = f \<odot> g \<oplus> f \<odot> h"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(f \<odot> (g \<oplus> h)) (i,j) = (\<Squnion>\<^sub>k f (i,k) * (g \<oplus> h) (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<squnion> h (k,j)))"
      by (simp add: sup_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<squnion> f (i,k) * h (k,j))"
      by (meson mult_left_dist_sup)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<squnion> (\<Squnion>\<^sub>k f (i,k) * h (k,j))"
      by (simp add: sup_monoid.sum.distrib)
    also have "... = (f \<odot> g) (i,j) \<squnion> (f \<odot> h) (i,j)"
      by (simp add: times_matrix_def)
    also have "... = (f \<odot> g \<oplus> f \<odot> h) (i,j)"
      by (simp add: sup_matrix_def)
    finally show "(f \<odot> (g \<oplus> h)) (i,j) = (f \<odot> g \<oplus> f \<odot> h) (i,j)"
      .
  qed
next
  fix f :: "('a,'b) square"
  show "f \<odot> mbot = mbot"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(f \<odot> mbot) (i,j) = (\<Squnion>\<^sub>k f (i,k) * mbot (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * bot)"
      by (simp add: bot_matrix_def)
    also have "... = bot"
      by simp
    also have "... = mbot (i,j)"
      by (simp add: bot_matrix_def)
    finally show "(f \<odot> mbot) (i,j) = mbot (i,j)"
      .
  qed
qed

interpretation matrix_bounded_idempotent_semiring: bounded_idempotent_semiring where sup = sup_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::bounded_idempotent_semiring) square" and top = top_matrix and one = one_matrix and times = times_matrix
proof
  fix f :: "('a,'b) square"
  show "f \<oplus> mtop = mtop"
  proof
    fix e
    have "(f \<oplus> mtop) e = f e \<squnion> mtop e"
      by (simp add: sup_matrix_def)
    also have "... = f e \<squnion> top"
      by (simp add: top_matrix_def)
    also have "... = top"
      by simp
    also have "... = mtop e"
      by (simp add: top_matrix_def)
    finally show "(f \<oplus> mtop) e = mtop e"
      .
  qed
qed

subsection \<open>Stone Relation Algebras\<close>

text \<open>
Finally, we show that matrices over Stone relation algebras form a Stone relation algebra.
\<close>

interpretation matrix_stone_relation_algebra: stone_relation_algebra where sup = sup_matrix and inf = inf_matrix and less_eq = less_eq_matrix and less = less_matrix and bot = "bot_matrix :: ('a::finite,'b::stone_relation_algebra) square" and top = top_matrix and uminus = uminus_matrix and one = one_matrix and times = times_matrix and conv = conv_matrix
proof
  fix f g h :: "('a,'b) square"
  show "(f \<odot> g) \<odot> h = f \<odot> (g \<odot> h)"
    by (simp add: matrix_monoid.mult_assoc)
next
  fix f g h :: "('a,'b) square"
  show "(f \<oplus> g) \<odot> h = f \<odot> h \<oplus> g \<odot> h"
    by (simp add: matrix_idempotent_semiring.mult_right_dist_sup)
next
  fix f :: "('a,'b) square"
  show "mbot \<odot> f = mbot"
    by simp
next
  fix f :: "('a,'b) square"
  show "mone \<odot> f = f"
    by simp
next
  fix f :: "('a,'b) square"
  show "f\<^sup>t\<^sup>t = f"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(f\<^sup>t\<^sup>t) (i,j) = ((f\<^sup>t) (j,i))\<^sup>T"
      by (simp add: conv_matrix_def)
    also have "... = f (i,j)"
      by (simp add: conv_matrix_def)
    finally show "(f\<^sup>t\<^sup>t) (i,j) = f (i,j)"
      .
  qed
next
  fix f g :: "('a,'b) square"
  show "(f \<oplus> g)\<^sup>t = f\<^sup>t \<oplus> g\<^sup>t"
  proof (rule ext, rule prod_cases)
    fix i j
    have "((f \<oplus> g)\<^sup>t) (i,j) = ((f \<oplus> g) (j,i))\<^sup>T"
      by (simp add: conv_matrix_def)
    also have "... = (f (j,i) \<squnion> g (j,i))\<^sup>T"
      by (simp add: sup_matrix_def)
    also have "... = (f\<^sup>t) (i,j) \<squnion> (g\<^sup>t) (i,j)"
      by (simp add: conv_matrix_def conv_dist_sup)
    also have "... = (f\<^sup>t \<oplus> g\<^sup>t) (i,j)"
      by (simp add: sup_matrix_def)
    finally show "((f \<oplus> g)\<^sup>t) (i,j) = (f\<^sup>t \<oplus> g\<^sup>t) (i,j)"
      .
  qed
next
  fix f g :: "('a,'b) square"
  show "(f \<odot> g)\<^sup>t = g\<^sup>t \<odot> f\<^sup>t"
  proof (rule ext, rule prod_cases)
    fix i j
    have "((f \<odot> g)\<^sup>t) (i,j) = ((f \<odot> g) (j,i))\<^sup>T"
      by (simp add: conv_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (j,k) * g (k,i))\<^sup>T"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k (f (j,k) * g (k,i))\<^sup>T)"
      by (metis (no_types) conv_dist_sum)
    also have "... = (\<Squnion>\<^sub>k (g (k,i))\<^sup>T * (f (j,k))\<^sup>T)"
      by (simp add: conv_dist_comp)
    also have "... = (\<Squnion>\<^sub>k (g\<^sup>t) (i,k) * (f\<^sup>t) (k,j))"
      by (simp add: conv_matrix_def)
    also have "... = (g\<^sup>t \<odot> f\<^sup>t) (i,j)"
      by (simp add: times_matrix_def)
    finally show "((f \<odot> g)\<^sup>t) (i,j) = (g\<^sup>t \<odot> f\<^sup>t) (i,j)"
      .
  qed
next
  fix f g h :: "('a,'b) square"
  show "(f \<odot> g) \<otimes> h \<preceq> f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))"
  proof (unfold less_eq_matrix_def, rule allI, rule prod_cases)
    fix i j
    have "((f \<odot> g) \<otimes> h) (i,j) = (f \<odot> g) (i,j) \<sqinter> h (i,j)"
      by (simp add: inf_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j)) \<sqinter> h (i,j)"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * g (k,j) \<sqinter> h (i,j))"
      by (metis (no_types) inf_right_dist_sum)
    also have "... \<le> (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f (i,k))\<^sup>T * h (i,j)))"
      by (rule leq_sum, meson dedekind_1)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f\<^sup>t) (k,i) * h (i,j)))"
      by (simp add: conv_matrix_def)
    also have "... \<le> (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (\<Squnion>\<^sub>l (f\<^sup>t) (k,l) * h (l,j))))"
      by (rule leq_sum, rule allI, rule comp_right_isotone, rule inf.sup_right_isotone, rule ub_sum)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g (k,j) \<sqinter> (f\<^sup>t \<odot> h) (k,j)))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k f (i,k) * (g \<otimes> (f\<^sup>t \<odot> h)) (k,j))"
      by (simp add: inf_matrix_def)
    also have "... = (f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))) (i,j)"
      by (simp add: times_matrix_def)
    finally show "((f \<odot> g) \<otimes> h) (i,j) \<le> (f \<odot> (g \<otimes> (f\<^sup>t \<odot> h))) (i,j)"
      .
  qed
next
  fix f g :: "('a,'b) square"
  show "\<ominus>\<ominus>(f \<odot> g) = \<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(\<ominus>\<ominus>(f \<odot> g)) (i,j) = --((f \<odot> g) (i,j))"
      by (simp add: uminus_matrix_def)
    also have "... = --(\<Squnion>\<^sub>k f (i,k) * g (k,j))"
      by (simp add: times_matrix_def)
    also have "... = (\<Squnion>\<^sub>k --(f (i,k) * g (k,j)))"
      by (metis (no_types) pp_dist_sum)
    also have "... = (\<Squnion>\<^sub>k --(f (i,k)) * --(g (k,j)))"
      by (meson pp_dist_comp)
    also have "... = (\<Squnion>\<^sub>k (\<ominus>\<ominus>f) (i,k) * (\<ominus>\<ominus>g) (k,j))"
      by (simp add: uminus_matrix_def)
    also have "... = (\<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g) (i,j)"
      by (simp add: times_matrix_def)
    finally show "(\<ominus>\<ominus>(f \<odot> g)) (i,j) = (\<ominus>\<ominus>f \<odot> \<ominus>\<ominus>g) (i,j)"
      .
  qed
next
  let ?o = "mone :: ('a,'b) square"
  show "\<ominus>\<ominus>?o = ?o"
  proof (rule ext, rule prod_cases)
    fix i j
    have "(\<ominus>\<ominus>?o) (i,j) = --(?o (i,j))"
      by (simp add: uminus_matrix_def)
    also have "... = --(if i = j then 1 else bot)"
      by (simp add: one_matrix_def)
    also have "... = (if i = j then --1 else --bot)"
      by simp
    also have "... = (if i = j then 1 else bot)"
      by auto
    also have "... = ?o (i,j)"
      by (simp add: one_matrix_def)
    finally show "(\<ominus>\<ominus>?o) (i,j) = ?o (i,j)"
      .
  qed
qed

end


(*  Title:      FOL/ex/Quantifiers_Cla.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section \<open>First-Order Logic: quantifier examples (classical version)\<close>

theory Quantifiers_Cla
imports FOL
begin

lemma \<open>(\<forall>x y. P(x,y)) \<longrightarrow> (\<forall>y x. P(x,y))\<close>
  by fast

lemma \<open>(\<exists>x y. P(x,y)) \<longrightarrow> (\<exists>y x. P(x,y))\<close>
  by fast

text \<open>Converse is false.\<close>
lemma \<open>(\<forall>x. P(x)) \<or> (\<forall>x. Q(x)) \<longrightarrow> (\<forall>x. P(x) \<or> Q(x))\<close>
  by fast

lemma \<open>(\<forall>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x. Q(x)))\<close>
  by fast

lemma \<open>(\<forall>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x. P(x)) \<longrightarrow> Q)\<close>
  by fast

text \<open>Some harder ones.\<close>

lemma \<open>(\<exists>x. P(x) \<or> Q(x)) \<longleftrightarrow> (\<exists>x. P(x)) \<or> (\<exists>x. Q(x))\<close>
  by fast

\<comment> \<open>Converse is false.\<close>
lemma \<open>(\<exists>x. P(x) \<and> Q(x)) \<longrightarrow> (\<exists>x. P(x)) \<and> (\<exists>x. Q(x))\<close>
  by fast

text \<open>Basic test of quantifier reasoning.\<close>

\<comment> \<open>TRUE\<close>
lemma \<open>(\<exists>y. \<forall>x. Q(x,y)) \<longrightarrow> (\<forall>x. \<exists>y. Q(x,y))\<close>
  by fast

lemma \<open>(\<forall>x. Q(x)) \<longrightarrow> (\<exists>x. Q(x))\<close>
  by fast

text \<open>The following should fail, as they are false!\<close>

lemma \<open>(\<forall>x. \<exists>y. Q(x,y)) \<longrightarrow> (\<exists>y. \<forall>x. Q(x,y))\<close>
  apply fast?
  oops

lemma \<open>(\<exists>x. Q(x)) \<longrightarrow> (\<forall>x. Q(x))\<close>
  apply fast?
  oops

schematic_goal \<open>P(?a) \<longrightarrow> (\<forall>x. P(x))\<close>
  apply fast?
  oops

schematic_goal \<open>(P(?a) \<longrightarrow> (\<forall>x. Q(x))) \<longrightarrow> (\<forall>x. P(x) \<longrightarrow> Q(x))\<close>
  apply fast?
  oops

text \<open>Back to things that are provable \dots\<close>

lemma \<open>(\<forall>x. P(x) \<longrightarrow> Q(x)) \<and> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x))\<close>
  by fast

text \<open>An example of why \<open>exI\<close> should be delayed as long as possible.\<close>
lemma \<open>(P \<longrightarrow> (\<exists>x. Q(x))) \<and> P \<longrightarrow> (\<exists>x. Q(x))\<close>
  by fast

schematic_goal \<open>(\<forall>x. P(x) \<longrightarrow> Q(f(x))) \<and> (\<forall>x. Q(x) \<longrightarrow> R(g(x))) \<and> P(d) \<longrightarrow> R(?a)\<close>
  by fast

lemma \<open>(\<forall>x. Q(x)) \<longrightarrow> (\<exists>x. Q(x))\<close>
  by fast

text \<open>Some slow ones\<close>

text \<open>Principia Mathematica *11.53\<close>
lemma \<open>(\<forall>x y. P(x) \<longrightarrow> Q(y)) \<longleftrightarrow> ((\<exists>x. P(x)) \<longrightarrow> (\<forall>y. Q(y)))\<close>
  by fast

(*Principia Mathematica *11.55  *)
lemma \<open>(\<exists>x y. P(x) \<and> Q(x,y)) \<longleftrightarrow> (\<exists>x. P(x) \<and> (\<exists>y. Q(x,y)))\<close>
  by fast

(*Principia Mathematica *11.61  *)
lemma \<open>(\<exists>y. \<forall>x. P(x) \<longrightarrow> Q(x,y)) \<longrightarrow> (\<forall>x. P(x) \<longrightarrow> (\<exists>y. Q(x,y)))\<close>
  by fast

end


theory hw2
imports Main
begin

fun add :: "nat \<Rightarrow> nat" where
  "add x = x + 1"

value "add 3"

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count x [] = 0"
| "count x (y # xs) = (if x = y then add (count x xs)  else count x xs) "

value "length [1::nat,3,5,3]"
value "count (3::nat) [1,3,5,3]"

theorem[simp]: "count a xs <= length xs"
  apply (induction xs)
  by auto

 (*define tree*)
datatype 'a tree = Tip | Node " 'a tree" 'a " 'a tree" | leave 'a

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node l a r ) = Node (mirror r ) a (mirror l)"
| "mirror (leave a) = leave a"

datatype 'a list = Nil | Cons 'a " 'a list"

thm list.induct

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

lemma app_nil [simp]: "app xs Nil = xs"
  apply (induction xs)
  by auto

lemma app_assoc [simp]: "app xs (app ys zs) = app (app xs ys) zs"
  apply (induction xs)
  by auto

fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

value "rev(Cons True (Cons False Nil))"
value "app (Cons a (Cons b Nil)) (Cons a (Cons c Nil))"

fun preorder :: "'a tree \<Rightarrow> 'a list" where
"preorder Tip = Nil"
| "preorder (Node l a r) = (app (app (Cons a Nil) (preorder l)) (preorder r))"
| "preorder (leave a)  = (Cons a Nil)"

value "preorder (Node (Node Tip f Tip) a Tip)"

fun postorder :: "'a tree \<Rightarrow> 'a list" where
"postorder Tip = Nil"
| "postorder (Node l a r) = (app (app (postorder l) (postorder r)) (Cons a Nil))"
| "postorder (leave a) = (Cons a Nil)"

value "rev (postorder (Node (Node Tip f Tip) a (Node (Node Tip a_1 Tip) a_2 (leave a_3))))"
value "preorder (mirror (Node (Node Tip f Tip) a (Node (Node Tip a_1 Tip) a_2 (leave a_3))))"

theorem Tip_lema1:
 "preorder (mirror Tip) = rev (postorder Tip)"
  apply (induction Tip)
  by auto

theorem leave_lema[simp]:
 "\<And>x. preorder (mirror (leave x)) = hw2.rev (postorder (leave x))"
  apply (induction)
  by auto

lemma rev_append [simp]: "rev (app xs ys) = app (rev ys) (rev xs)"
  apply (induction xs)
  by auto

theorem final : "preorder (mirror t) = rev (postorder t)"
  apply (induction t)
  by auto

end