(*
  File:     Miller_Rabin.thy
  Authors:  Daniel Stüwe

  Some facts about Quadratic Residues that are missing from the library
*)
section \<open>Additional Material on Quadratic Residues\<close>
theory QuadRes
imports
  Jacobi_Symbol
  Algebraic_Auxiliaries
begin

text \<open>Proofs are inspired by \cite{Quadratic_Residues}.\<close>

lemma inj_on_QuadRes:
  fixes p :: int
  assumes "prime p"
  shows "inj_on (\<lambda>x. x^2 mod p) {0..(p-1) div 2}"
proof
  fix x y :: int
  assume elem: "x \<in> {0..(p-1) div 2}" "y \<in> {0..(p-1) div 2}"

  have * : "abs(a) < p \<Longrightarrow> p dvd a \<Longrightarrow> a = 0" for a :: int
    using dvd_imp_le_int by force

  assume "x\<^sup>2 mod p = y\<^sup>2 mod p"

  hence "[x\<^sup>2 = y\<^sup>2] (mod p)" unfolding cong_def .

  hence "p dvd (x\<^sup>2 - y\<^sup>2)" by (simp add: cong_iff_dvd_diff)

  hence "p dvd (x + y) * (x - y)"
    by (simp add: power2_eq_square square_diff_square_factored)

  hence "p dvd (x + y) \<or> p dvd (x - y)"
    using \<open>prime p\<close> by (simp add: prime_dvd_mult_iff)

  moreover have "p dvd x + y \<Longrightarrow> x + y = 0" "p dvd x - y \<Longrightarrow> x - y = 0"
           and "0 \<le> x" "0 \<le> y"
      using elem
      by (fastforce intro!: * )+

  ultimately show "x = y" by auto
qed

lemma QuadRes_set_prime:
  assumes "prime p" and "odd p"
  shows "{x . QuadRes p x \<and> x \<in> {0..<p}} = {x^2 mod p | x . x \<in> {0..(p-1) div 2}}"
proof(safe, goal_cases)
  case (1 x)
  then obtain y where "[y\<^sup>2 = x] (mod p)"
    unfolding QuadRes_def by blast

  then have A: "[(y mod p)\<^sup>2 = x] (mod p)"
    unfolding cong_def
    by (simp add: power_mod)

  then have "[(-(y mod p))\<^sup>2 = x] (mod p)"
    by simp

  then have B: "[(p - (y mod p))\<^sup>2 = x] (mod p)"
    unfolding cong_def
    using minus_mod_self1
    by (metis power_mod)

  have "p = 1 + ((p - 1) div 2) * 2"
    using prime_gt_0_int[OF \<open>prime p\<close>] \<open>odd p\<close>
    by simp

  then have C: "(p - (y mod p)) \<in> {0..(p - 1) div 2} \<or> y mod p \<in> {0..(p - 1) div 2}"
    using prime_gt_0_int[OF \<open>prime p\<close>]
    by (clarsimp, auto simp: le_less)

  then show ?case proof
    show ?thesis if "p - y mod p \<in> {0..(p - 1) div 2}"
      using that B
      unfolding cong_def
      using \<open>x \<in> {0..<p}\<close> by auto

    show ?thesis if "y mod p \<in> {0..(p - 1) div 2}"
      using that A
      unfolding cong_def
      using \<open>x \<in> {0..<p}\<close> by auto
  qed
qed (auto simp: QuadRes_def cong_def)

corollary QuadRes_iff:
  assumes "prime p" and "odd p"
  shows "(QuadRes p x \<and> x \<in> {0..<p}) \<longleftrightarrow> (\<exists> a \<in> {0..(p-1) div 2}. a^2 mod p = x)"
proof -
  have "(QuadRes p x \<and> x \<in> {0..<p}) \<longleftrightarrow> x \<in> {x. QuadRes p x \<and> x \<in> {0..<p}}"
    by auto
  also note QuadRes_set_prime[OF assms]
  also have "(x \<in> {x\<^sup>2 mod p |x. x \<in> {0..(p - 1) div 2}}) = (\<exists>a\<in>{0..(p - 1) div 2}. a\<^sup>2 mod p = x)"
    by blast
  finally show ?thesis .
qed

corollary card_QuadRes_set_prime:
  fixes p :: int
  assumes "prime p" and "odd p"
  shows "card {x. QuadRes p x \<and> x \<in> {0..<p}} = nat (p+1) div 2"
proof -
  have "card {x. QuadRes p x \<and> x \<in> {0..<p}} = card {x\<^sup>2 mod p | x . x \<in> {0..(p-1) div 2}}"
    unfolding QuadRes_set_prime[OF assms] ..

  also have "{x\<^sup>2 mod p | x . x \<in> {0..(p-1) div 2}} = (\<lambda>x. x\<^sup>2 mod p) ` {0..(p-1) div 2}"
    by auto

  also have "card ... = card {0..(p-1) div 2}"
    using inj_on_QuadRes[OF \<open>prime p\<close>] by (rule card_image)

  also have "... = nat (p+1) div 2" by simp

  finally show ?thesis .
qed

corollary card_not_QuadRes_set_prime:
  fixes p :: int
  assumes "prime p" and "odd p"
  shows "card {x. \<not>QuadRes p x \<and> x \<in> {0..<p}} = nat (p-1) div 2"
proof -
  have "{0..<p} \<inter> {x. QuadRes p x \<and> x \<in> {0..<p}} = {x. QuadRes p x \<and> x \<in> {0..<p}}"
    by blast

  moreover have "nat p - nat (p + 1) div 2 = nat (p - 1) div 2"
    using \<open>odd p\<close> prime_gt_0_int[OF \<open>prime p\<close>]
    by (auto elim!: oddE simp: nat_add_distrib nat_mult_distrib)

  ultimately have "card {0..<p} - card ({0..<p} \<inter> {x. QuadRes p x \<and> x \<in> {0..<p}}) = nat (p - 1) div 2"
    using card_QuadRes_set_prime[OF assms] and card_atLeastZeroLessThan_int by presburger

  moreover have "{x. \<not>QuadRes p x \<and> x \<in> {0..<p}} = {0..<p} - {x. QuadRes p x \<and> x \<in> {0..<p}}"
    by blast

  ultimately show ?thesis by (auto simp add: card_Diff_subset_Int)
qed

lemma not_QuadRes_ex_if_prime:
  assumes "prime p" and "odd p"
  shows "\<exists> x. \<not>QuadRes p x"
proof -
  have "2 < p" using odd_prime_gt_2_int assms by blast

  then have False if "{x . \<not>QuadRes p x \<and> x \<in> {0..<p}} = {}"
    using card_not_QuadRes_set_prime[OF assms]
    unfolding that
    by simp

  thus ?thesis by blast
qed

lemma not_QuadRes_ex:
  "1 < p \<Longrightarrow> odd p \<Longrightarrow> \<exists>x. \<not>QuadRes p x"
proof (induction p rule: prime_divisors_induct)
  case (factor p x)
  then show ?case
    by (meson not_QuadRes_ex_if_prime QuadRes_def cong_iff_dvd_diff dvd_mult_left even_mult_iff)
qed simp_all

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: Sum_Order.thy                                                        *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Sum Type Order\<close>

theory Sum_Order
imports Main
begin

subsection \<open>Instantiation of @{class ord}\<close>

instantiation sum :: (ord, ord) ord
begin
fun less_eq_sum :: "'a + 'b \<Rightarrow> 'a + 'b \<Rightarrow> bool" where
"less_eq_sum (Inl x) (Inl y) \<longleftrightarrow> x \<le> y" |
"less_eq_sum (Inr x) (Inr y) \<longleftrightarrow> x \<le> y" |
"less_eq_sum (Inl x) (Inr y) \<longleftrightarrow> False" |
"less_eq_sum (Inr x) (Inl y) \<longleftrightarrow> False"

definition less_sum :: "'a + 'b \<Rightarrow> 'a + 'b \<Rightarrow> bool" where
"less_sum x y \<longleftrightarrow> (x \<le> y) \<and> x \<noteq> y"
instance by (intro_classes)
end

subsection \<open>Instantiation of @{class order}\<close>

instantiation sum :: (order, order) order
begin
theorem less_le_not_le_sum :
fixes x :: "'a + 'b"
fixes y :: "'a + 'b"
shows "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
apply (unfold less_sum_def)
apply (induct x; induct y)
apply (auto)
done

theorem order_refl_sum :
fixes x :: "'a + 'b"
shows "x \<le> x"
apply (induct x)
apply (auto)
done

theorem order_trans_sum :
fixes x :: "'a + 'b"
fixes y :: "'a + 'b"
fixes z :: "'a + 'b"
shows "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
apply (atomize (full))
apply (induct x; induct y; induct z)
apply (auto)
done

theorem antisym_sum :
fixes x :: "'a + 'b"
fixes y :: "'a + 'b"
shows "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
apply (atomize (full))
apply (induct x; induct y)
apply (auto)
done

instance
apply (intro_classes)
apply (metis less_le_not_le_sum)
apply (metis order_refl_sum)
apply (metis order_trans_sum)
apply (metis antisym_sum)
done
end
end


(* Title:      Demonic refinement algebra
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Demonic Refinement Algebras\<close>

theory DRA
  imports Kleene_Algebra
begin

text \<open>
  A demonic refinement algebra *DRA)~\cite{vonwright04refinement} is a Kleene algebra without right annihilation plus
  an operation for possibly infinite iteration.
\<close>
class dra = kleene_algebra_zerol +
  fixes strong_iteration :: "'a \<Rightarrow> 'a" ("_\<^sup>\<infinity>" [101] 100)
  assumes iteration_unfoldl [simp] : "1 + x \<cdot> x\<^sup>\<infinity> = x\<^sup>\<infinity>"
  and coinduction: "y \<le> z + x \<cdot> y \<longrightarrow> y \<le> x\<^sup>\<infinity> \<cdot> z"
  and isolation [simp]: "x\<^sup>\<star> + x\<^sup>\<infinity> \<cdot> 0 = x\<^sup>\<infinity>"
begin

text \<open>$\top$ is an abort statement, defined as an infinite skip. It is the maximal element of any DRA.\<close>

abbreviation top_elem :: "'a" ("\<top>") where "\<top> \<equiv> 1\<^sup>\<infinity>"

text \<open>Simple/basic lemmas about the iteration operator\<close>

lemma iteration_refl: "1 \<le> x\<^sup>\<infinity>"
  using local.iteration_unfoldl local.order_prop by blast

lemma iteration_1l: "x \<cdot> x\<^sup>\<infinity> \<le> x\<^sup>\<infinity>"
  by (metis local.iteration_unfoldl local.join.sup.cobounded2)

lemma top_ref: "x \<le> \<top>"
proof -
  have "x \<le> 1 + 1 \<cdot> x"
    by simp
  thus ?thesis
    using local.coinduction by fastforce
qed

lemma it_ext: "x \<le> x\<^sup>\<infinity>"
proof -
  have "x \<le> x \<cdot> x\<^sup>\<infinity>"
    using iteration_refl local.mult_isol by fastforce
  thus ?thesis
    by (metis (full_types) local.isolation local.join.sup.coboundedI1 local.star_ext)
qed

lemma it_idem [simp]: "(x\<^sup>\<infinity>)\<^sup>\<infinity> = x\<^sup>\<infinity>"
(*nitpick [expect=genuine]*)
oops

lemma top_mult_annil [simp]: "\<top> \<cdot> x = \<top>"
  by (simp add: local.coinduction local.order.antisym top_ref)

lemma top_add_annil [simp]: "\<top> + x = \<top>"
  by (simp add: local.join.sup.absorb1 top_ref)

lemma top_elim: "x \<cdot> y \<le> x \<cdot> \<top>"
  by (simp add: local.mult_isol top_ref)

lemma iteration_unfoldl_distl [simp]: " y + y \<cdot> x \<cdot> x\<^sup>\<infinity> = y \<cdot> x\<^sup>\<infinity>"
  by (metis distrib_left mult.assoc mult_oner iteration_unfoldl)

lemma iteration_unfoldl_distr [simp]: " y + x \<cdot> x\<^sup>\<infinity> \<cdot> y = x\<^sup>\<infinity> \<cdot> y"
  by (metis distrib_right' mult_1_left iteration_unfoldl)

lemma iteration_unfoldl' [simp]: "z \<cdot> y + z \<cdot> x \<cdot> x\<^sup>\<infinity> \<cdot> y = z \<cdot> x\<^sup>\<infinity> \<cdot> y"
  by (metis iteration_unfoldl_distl local.distrib_right)

lemma iteration_idem [simp]: "x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity> = x\<^sup>\<infinity>"
proof (rule antisym)
  have "x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity> \<le> 1 + x \<cdot> x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity>"
    by (metis add_assoc iteration_unfoldl_distr local.eq_refl local.iteration_unfoldl local.subdistl_eq mult_assoc)
  thus "x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity> \<le> x\<^sup>\<infinity>"
    using local.coinduction mult_assoc by fastforce
  show "x\<^sup>\<infinity> \<le>  x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity>"
    using local.coinduction by auto
qed

lemma iteration_induct: "x \<cdot> x\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> x"
proof -
  have "x + x \<cdot> (x \<cdot> x\<^sup>\<infinity>) = x \<cdot> x\<^sup>\<infinity>"
    by (metis (no_types) local.distrib_left local.iteration_unfoldl local.mult_oner)
  thus ?thesis
    by (simp add: local.coinduction)
qed

lemma iteration_ref_star: "x\<^sup>\<star> \<le> x\<^sup>\<infinity>"
  by (simp add: local.star_inductl_one)

lemma iteration_subdist: "x\<^sup>\<infinity> \<le> (x + y)\<^sup>\<infinity>"
  by (metis add_assoc' distrib_right' mult_oner coinduction join.sup_ge1 iteration_unfoldl)

lemma iteration_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<infinity> \<le> y\<^sup>\<infinity>"
  using iteration_subdist local.order_prop by auto

lemma iteration_unfoldr [simp]: "1 + x\<^sup>\<infinity> \<cdot> x = x\<^sup>\<infinity>"
  by (metis add_0_left annil eq_refl isolation mult.assoc iteration_idem iteration_unfoldl iteration_unfoldl_distr star_denest star_one star_prod_unfold star_slide tc)

lemma iteration_unfoldr_distl [simp]: " y + y \<cdot> x\<^sup>\<infinity> \<cdot> x = y \<cdot> x\<^sup>\<infinity>"
  by (metis distrib_left mult.assoc mult_oner iteration_unfoldr)

lemma iteration_unfoldr_distr [simp]: " y + x\<^sup>\<infinity> \<cdot> x \<cdot> y = x\<^sup>\<infinity> \<cdot> y"
  by (metis iteration_unfoldl_distr iteration_unfoldr_distl)

lemma iteration_unfold_eq: "x\<^sup>\<infinity> \<cdot> x = x \<cdot> x\<^sup>\<infinity>"
  by (metis iteration_unfoldl_distr iteration_unfoldr_distl)

lemma iteration_unfoldr' [simp]: "z \<cdot> y + z \<cdot> x\<^sup>\<infinity> \<cdot> x \<cdot> y = z \<cdot> x\<^sup>\<infinity> \<cdot> y"
  by (metis distrib_left mult.assoc iteration_unfoldr_distr)

lemma iteration_double [simp]: "(x\<^sup>\<infinity>)\<^sup>\<infinity> = \<top>"
  by (simp add: iteration_iso iteration_refl local.eq_iff top_ref)

lemma star_iteration [simp]: "(x\<^sup>\<star>)\<^sup>\<infinity> = \<top>"
  by (simp add: iteration_iso local.eq_iff top_ref)

lemma iteration_star [simp]: "(x\<^sup>\<infinity>)\<^sup>\<star> = x\<^sup>\<infinity>"
  by (metis (no_types) iteration_idem iteration_refl local.star_inductr_var_eq2 local.sup_id_star1)

lemma iteration_star2 [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<infinity> = x\<^sup>\<infinity>"
proof -
  have f1: "(x\<^sup>\<infinity>)\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<infinity>"
    by (metis (no_types) it_ext iteration_induct iteration_star local.bubble_sort local.join.sup.absorb1)
  have "x\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity>"
    by simp
  hence "x\<^sup>\<star> \<cdot> x\<^sup>\<infinity> = x\<^sup>\<star> \<cdot> (x\<^sup>\<infinity>)\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> (x\<^sup>\<infinity>)\<^sup>\<star>)\<^sup>\<star>"
    using f1 by (metis (no_types) iteration_star local.star_denest_var_4 mult_assoc)
  thus ?thesis
    using f1 by (metis (no_types) iteration_star local.star_denest_var_4 local.star_denest_var_8)
qed

lemma iteration_zero [simp]: "0\<^sup>\<infinity> = 1"
  by (metis add_zeror annil iteration_unfoldl)

lemma iteration_subdenest: "x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> \<le> (x + y)\<^sup>\<infinity>"
  by (metis add_commute iteration_idem iteration_subdist local.mult_isol_var)

lemma sup_id_top: "1 \<le> y \<Longrightarrow> y \<cdot> \<top> = \<top>"
  using local.eq_iff local.mult_isol_var top_ref by fastforce

lemma iteration_top [simp]: "x\<^sup>\<infinity> \<cdot> \<top> = \<top>"
  by (simp add: iteration_refl sup_id_top)

text \<open>Next, we prove some simulation laws for data refinement.\<close>

lemma iteration_sim: "z \<cdot> y \<le> x \<cdot> z \<Longrightarrow> z \<cdot> y\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> z"
proof -
  assume assms: "z \<cdot> y \<le> x \<cdot> z"
  have "z \<cdot> y\<^sup>\<infinity> = z + z \<cdot> y \<cdot> y\<^sup>\<infinity>"
    by simp
  also have "... \<le> z + x \<cdot> z \<cdot> y\<^sup>\<infinity>"
    by (metis assms add.commute add_iso mult_isor)
  finally show "z \<cdot> y\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> z"
    by (simp add: local.coinduction mult_assoc)
qed

text \<open>Nitpick gives a counterexample to the dual simulation law.\<close>

lemma "y \<cdot> z \<le> z \<cdot> x \<Longrightarrow> y\<^sup>\<infinity> \<cdot> z \<le> z \<cdot> x\<^sup>\<infinity>"
(*nitpick [expect=genuine]*)
oops

text \<open>Next, we prove some sliding laws.\<close>

lemma iteration_slide_var: "x \<cdot> (y \<cdot> x)\<^sup>\<infinity> \<le> (x \<cdot> y)\<^sup>\<infinity> \<cdot> x"
  by (simp add: iteration_sim mult_assoc)

lemma iteration_prod_unfold [simp]: "1 + y \<cdot> (x \<cdot> y)\<^sup>\<infinity> \<cdot> x = (y \<cdot> x)\<^sup>\<infinity>"
proof (rule antisym)
  have "1 + y \<cdot> (x \<cdot> y)\<^sup>\<infinity> \<cdot> x \<le> 1 + (y \<cdot> x)\<^sup>\<infinity> \<cdot> y \<cdot> x"
    using iteration_slide_var local.join.sup_mono local.mult_isor by blast
  thus "1 + y \<cdot> (x \<cdot> y)\<^sup>\<infinity> \<cdot> x \<le>  (y \<cdot> x)\<^sup>\<infinity>"
    by (simp add: mult_assoc)
  have "(y \<cdot> x)\<^sup>\<infinity> = 1 + y \<cdot> x \<cdot> (y \<cdot> x)\<^sup>\<infinity>"
    by simp
  thus "(y \<cdot> x)\<^sup>\<infinity> \<le> 1 + y \<cdot> (x \<cdot> y)\<^sup>\<infinity> \<cdot> x"
    by (metis iteration_sim local.eq_refl local.join.sup.mono local.mult_isol mult_assoc)
qed

lemma iteration_slide: "x \<cdot> (y \<cdot> x)\<^sup>\<infinity> = (x \<cdot> y)\<^sup>\<infinity> \<cdot> x"
  by (metis iteration_prod_unfold iteration_unfoldl_distr distrib_left mult_1_right mult.assoc)

lemma star_iteration_slide [simp]: " y\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> y)\<^sup>\<infinity> = (x\<^sup>\<star> \<cdot> y)\<^sup>\<infinity>"
  by (metis iteration_star2 local.conway.dagger_unfoldl_distr local.join.sup.orderE local.mult_isor local.star_invol local.star_subdist local.star_trans_eq)

text \<open>The following laws are called denesting laws.\<close>

lemma iteration_sub_denest: "(x + y)\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity>"
proof -
  have "(x + y)\<^sup>\<infinity> = x \<cdot> (x + y)\<^sup>\<infinity> + y \<cdot> (x + y)\<^sup>\<infinity> + 1"
    by (metis add.commute distrib_right' iteration_unfoldl)
  hence "(x + y)\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> (y \<cdot> (x + y)\<^sup>\<infinity> + 1)"
    by (metis add_assoc' join.sup_least join.sup_ge1 join.sup_ge2 coinduction)
  moreover hence "x\<^sup>\<infinity> \<cdot> (y \<cdot> (x + y)\<^sup>\<infinity> + 1) \<le> x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis add_iso mult.assoc mult_isol add.commute coinduction mult_oner mult_isol)
  ultimately show ?thesis
    using local.order_trans by blast
qed

lemma iteration_denest: "(x + y)\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity>"
proof -
  have "x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity> \<le> x \<cdot> x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity> + y \<cdot> x\<^sup>\<infinity> \<cdot> (y \<cdot> x\<^sup>\<infinity>)\<^sup>\<infinity> + 1"
    by (metis add.commute iteration_unfoldl_distr add_assoc' add.commute iteration_unfoldl order_refl)
  thus ?thesis
    by (metis add.commute iteration_sub_denest order.antisym coinduction distrib_right' iteration_sub_denest mult.assoc mult_oner order.antisym)
qed
(*
end

sublocale dra \<subseteq> conway_zerol strong_iteration
  apply (unfold_locales)
  apply (simp add: iteration_denest iteration_slide)
  apply simp
  by (simp add: iteration_sim)

context dra
begin
*)
lemma iteration_denest2 [simp]: "y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<infinity> + y\<^sup>\<infinity> = (x + y)\<^sup>\<infinity>"
proof -
  have "(x + y)\<^sup>\<infinity> = y\<^sup>\<infinity> \<cdot> x \<cdot> (y\<^sup>\<infinity> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis add.commute iteration_denest iteration_slide iteration_unfoldl_distr)
  also have "... = y\<^sup>\<star> \<cdot> x \<cdot> (y\<^sup>\<infinity> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> + y\<^sup>\<infinity> \<cdot> 0 + y\<^sup>\<infinity>"
    by (metis isolation mult.assoc distrib_right' annil mult.assoc)
  also have "... = y\<^sup>\<star> \<cdot> x \<cdot> (y\<^sup>\<infinity> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis add.assoc distrib_left mult_1_right add_0_left mult_1_right)
  finally show ?thesis
    by (metis add.commute iteration_denest iteration_slide mult.assoc)
qed

lemma iteration_denest3: "(y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> = (x + y)\<^sup>\<infinity>"
proof (rule antisym)
  have  "(y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> \<le> (y\<^sup>\<infinity> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (simp add: iteration_iso iteration_ref_star local.mult_isor)
  thus  "(y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> \<le> (x + y)\<^sup>\<infinity>"
    by (metis iteration_denest iteration_slide local.join.sup_commute)
  have "(x + y)\<^sup>\<infinity> = y\<^sup>\<infinity> + y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<infinity>"
    by (metis iteration_denest2 local.join.sup_commute)
  thus "(x + y)\<^sup>\<infinity> \<le> (y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (simp add: local.coinduction)
qed

text \<open>Now we prove separation laws for reasoning about distributed systems in the context of action systems.\<close>

lemma iteration_sep: "y \<cdot> x \<le> x \<cdot> y \<Longrightarrow> (x + y)\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
proof -
  assume "y \<cdot> x \<le> x \<cdot> y"
  hence "y\<^sup>\<star> \<cdot> x \<le> x\<cdot>(x + y)\<^sup>\<star>"
    by (metis star_sim1 add.commute mult_isol order_trans star_subdist)
  hence "y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<infinity> + y\<^sup>\<infinity> \<le> x \<cdot> (x + y)\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis mult_isor mult.assoc iteration_star2 join.sup.mono eq_refl)
  thus ?thesis
    by (metis iteration_denest2 add.commute coinduction add.commute less_eq_def iteration_subdenest)
qed

lemma iteration_sim2: "y \<cdot> x \<le> x \<cdot> y \<Longrightarrow> y\<^sup>\<infinity> \<cdot> x\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
  by (metis add.commute iteration_sep iteration_subdenest)

lemma iteration_sep2: "y \<cdot> x \<le> x \<cdot> y\<^sup>\<star> \<Longrightarrow> (x + y)\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
proof -
  assume "y \<cdot> x \<le> x \<cdot> y\<^sup>\<star>"
  hence "y\<^sup>\<star> \<cdot> (y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> y\<^sup>\<star> \<cdot> y\<^sup>\<infinity>"
    by (metis mult.assoc mult_isor iteration_sim star_denest_var_2 star_sim1 star_slide_var star_trans_eq tc_eq)
  moreover have "x\<^sup>\<infinity> \<cdot> y\<^sup>\<star> \<cdot> y\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (metis eq_refl mult.assoc iteration_star2)
  moreover have "(y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity> \<le> y\<^sup>\<star> \<cdot> (y\<^sup>\<star> \<cdot> x)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (metis mult_isor mult_onel star_ref)
  ultimately show ?thesis
    by (metis antisym iteration_denest3 iteration_subdenest order_trans)
qed

lemma iteration_sep3: "y \<cdot> x \<le> x \<cdot> (x + y) \<Longrightarrow> (x + y)\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
proof -
  assume "y \<cdot> x \<le> x \<cdot> (x + y)"
  hence "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    by (metis star_sim1)
  hence "y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<infinity> + y\<^sup>\<infinity> \<le> x \<cdot> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis add_iso mult_isor)
  hence "(x + y)\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (metis mult.assoc iteration_denest2 iteration_star2 add.commute coinduction)
  thus ?thesis
    by (metis add.commute less_eq_def iteration_subdenest)
qed

lemma iteration_sep4: "y \<cdot> 0 = 0 \<Longrightarrow> z \<cdot> x = 0 \<Longrightarrow> y \<cdot> x \<le> (x + z) \<cdot> y\<^sup>\<star> \<Longrightarrow> (x + y + z)\<^sup>\<infinity> = x\<^sup>\<infinity> \<cdot> (y + z)\<^sup>\<infinity>"
proof -
  assume assms: "y \<cdot> 0 = 0" "z \<cdot> x = 0" "y \<cdot> x \<le> (x + z) \<cdot> y\<^sup>\<star>"
  have "y \<cdot> y\<^sup>\<star> \<cdot> z \<le> y\<^sup>\<star> \<cdot> z \<cdot> y\<^sup>\<star>"
    by (metis mult_isor star_1l mult_oner order_trans star_plus_one subdistl)
  have "y\<^sup>\<star> \<cdot> z \<cdot> x \<le> x \<cdot> y\<^sup>\<star> \<cdot> z"
    by (metis join.bot_least assms(1) assms(2) independence1 mult.assoc)
  have "y \<cdot> (x + y\<^sup>\<star> \<cdot> z) \<le> (x + z) \<cdot> y\<^sup>\<star> + y \<cdot> y\<^sup>\<star> \<cdot> z"
    by (metis assms(3) distrib_left mult.assoc add_iso)
  also have "... \<le> (x + y\<^sup>\<star> \<cdot> z) \<cdot> y\<^sup>\<star> + y \<cdot> y\<^sup>\<star> \<cdot> z"
    by (metis star_ref join.sup.mono eq_refl mult_1_left mult_isor)
  also have "... \<le> (x + y\<^sup>\<star> \<cdot> z) \<cdot> y\<^sup>\<star> + y\<^sup>\<star> \<cdot> z  \<cdot> y\<^sup>\<star>" using \<open>y \<cdot> y\<^sup>\<star> \<cdot> z \<le> y\<^sup>\<star> \<cdot> z \<cdot> y\<^sup>\<star>\<close>
    by (metis add.commute add_iso)
  finally have "y \<cdot> (x + y\<^sup>\<star> \<cdot> z) \<le> (x + y\<^sup>\<star> \<cdot> z) \<cdot> y\<^sup>\<star>"
    by (metis add.commute add_idem' add.left_commute distrib_right)
  moreover have "(x + y + z)\<^sup>\<infinity> \<le> (x + y + y\<^sup>\<star> \<cdot> z)\<^sup>\<infinity>"
    by (metis star_ref join.sup.mono eq_refl mult_1_left mult_isor iteration_iso)
  moreover have "... = (x + y\<^sup>\<star> \<cdot> z)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>"
    by (metis add_commute calculation(1) iteration_sep2 local.add_left_comm)
  moreover have "... = x\<^sup>\<infinity> \<cdot> (y\<^sup>\<star> \<cdot> z)\<^sup>\<infinity> \<cdot> y\<^sup>\<infinity>" using \<open>y\<^sup>\<star> \<cdot> z \<cdot> x \<le> x \<cdot> y\<^sup>\<star> \<cdot> z\<close>
    by (metis iteration_sep mult.assoc)
  ultimately have "(x + y + z)\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> (y + z)\<^sup>\<infinity>"
    by (metis add.commute mult.assoc iteration_denest3)
  thus ?thesis
    by (metis add.commute add.left_commute less_eq_def iteration_subdenest)
qed

text \<open>Finally, we prove some blocking laws.\<close>

text \<open>Nitpick refutes the next lemma.\<close>

lemma "x \<cdot> y = 0 \<Longrightarrow> x\<^sup>\<infinity> \<cdot> y = y"
(*nitpick*)
oops

lemma iteration_idep: "x \<cdot> y = 0 \<Longrightarrow> x \<cdot> y\<^sup>\<infinity> = x"
  by (metis add_zeror annil iteration_unfoldl_distl)

text \<open>Nitpick refutes the next lemma.\<close>

lemma "y \<cdot> w \<le> x \<cdot> y + z \<Longrightarrow> y \<cdot> w\<^sup>\<infinity> \<le> x\<^sup>\<infinity> \<cdot> z"
(*nitpick [expect=genuine]*)
oops

text \<open>At the end of this file, we consider a data refinement example from von Wright~\cite{Wright02}.\<close>

lemma data_refinement:
  assumes "s' \<le> s \<cdot> z" and "z \<cdot> e' \<le> e" and "z \<cdot> a' \<le> a \<cdot> z" and "z \<cdot> b \<le> z" and "b\<^sup>\<infinity> = b\<^sup>\<star>"
  shows "s' \<cdot> (a' + b)\<^sup>\<infinity> \<cdot> e' \<le> s \<cdot> a\<^sup>\<infinity> \<cdot> e"
proof -
  have "z \<cdot> b\<^sup>\<star> \<le> z"
    by (metis assms(4) star_inductr_var)
  have "(z \<cdot> a') \<cdot> b\<^sup>\<star> \<le> (a \<cdot> z) \<cdot> b\<^sup>\<star>"
    by (metis assms(3) mult.assoc mult_isor)
  hence "z \<cdot> (a' \<cdot> b\<^sup>\<star>)\<^sup>\<infinity> \<le>  a\<^sup>\<infinity> \<cdot> z" using \<open>z \<cdot> b\<^sup>\<star> \<le> z\<close>
    by (metis mult.assoc mult_isol order_trans iteration_sim mult.assoc)
  have "s' \<cdot> (a' + b)\<^sup>\<infinity> \<cdot> e' \<le> s' \<cdot> b\<^sup>\<star> \<cdot> (a' \<cdot> b\<^sup>\<star>)\<^sup>\<infinity> \<cdot> e'"
    by (metis add.commute assms(5) eq_refl iteration_denest mult.assoc)
  also have "... \<le> s \<cdot> z \<cdot> b\<^sup>\<star> \<cdot> (a' \<cdot> b\<^sup>\<star>)\<^sup>\<infinity> \<cdot> e'"
    by (metis assms(1) mult_isor)
  also have "... \<le> s \<cdot> z \<cdot> (a' \<cdot> b\<^sup>\<star>)\<^sup>\<infinity> \<cdot> e'" using \<open>z \<cdot> b\<^sup>\<star> \<le> z\<close>
    by (metis mult.assoc mult_isol mult_isor)
  also have "... \<le> s \<cdot> a\<^sup>\<infinity> \<cdot> z \<cdot> e'" using \<open>z \<cdot> (a' \<cdot> b\<^sup>\<star>)\<^sup>\<infinity> \<le>  a\<^sup>\<infinity> \<cdot> z\<close>
    by (metis mult.assoc mult_isol mult_isor)
  finally show ?thesis
    by (metis assms(2) mult.assoc mult_isol mult.assoc mult_isol order_trans)
qed

end

end


(*  Title:      ZF/OrdQuant.thy
    Authors:    Krzysztof Grabczewski and L C Paulson
*)

section \<open>Special quantifiers\<close>

theory OrdQuant imports Ordinal begin

subsection \<open>Quantifiers and union operator for ordinals\<close>

definition
  (* Ordinal Quantifiers *)
  oall :: "[i, i \<Rightarrow> o] \<Rightarrow> o"  where
    "oall(A, P) \<equiv> \<forall>x. x<A \<longrightarrow> P(x)"

definition
  oex :: "[i, i \<Rightarrow> o] \<Rightarrow> o"  where
    "oex(A, P)  \<equiv> \<exists>x. x<A \<and> P(x)"

definition
  (* Ordinal Union *)
  OUnion :: "[i, i \<Rightarrow> i] \<Rightarrow> i"  where
    "OUnion(i,B) \<equiv> {z: \<Union>x\<in>i. B(x). Ord(i)}"

syntax
  "_oall"     :: "[idt, i, o] \<Rightarrow> o"        (\<open>(3\<forall>_<_./ _)\<close> 10)
  "_oex"      :: "[idt, i, o] \<Rightarrow> o"        (\<open>(3\<exists>_<_./ _)\<close> 10)
  "_OUNION"   :: "[idt, i, i] \<Rightarrow> i"        (\<open>(3\<Union>_<_./ _)\<close> 10)
translations
  "\<forall>x<a. P" \<rightleftharpoons> "CONST oall(a, \<lambda>x. P)"
  "\<exists>x<a. P" \<rightleftharpoons> "CONST oex(a, \<lambda>x. P)"
  "\<Union>x<a. B" \<rightleftharpoons> "CONST OUnion(a, \<lambda>x. B)"

subsubsection \<open>simplification of the new quantifiers\<close>

(*MOST IMPORTANT that this is added to the simpset BEFORE Ord_atomize
  is proved.  Ord_atomize would convert this rule to
    x < 0 \<Longrightarrow> P(x) \<equiv> True, which causes dire effects!*)

lemma [simp]: "\<not>(\<exists>x<0. P(x))"
by (simp add: oex_def)

lemma [simp]: "(\<forall>x<succ(i). P(x)) <-> (Ord(i) \<longrightarrow> P(i) \<and> (\<forall>x<i. P(x)))"
apply (simp add: oall_def le_iff)
apply (blast intro: lt_Ord2)
done

lemma [simp]: "(\<exists>x<succ(i). P(x)) <-> (Ord(i) \<and> (P(i) | (\<exists>x<i. P(x))))"
apply (simp add: oex_def le_iff)
apply (blast intro: lt_Ord2)
done

subsubsection \<open>Union over ordinals\<close>

lemma Ord_OUN [intro,simp]:
     "\<lbrakk>\<And>x. x<A \<Longrightarrow> Ord(B(x))\<rbrakk> \<Longrightarrow> Ord(\<Union>x<A. B(x))"
by (simp add: OUnion_def ltI Ord_UN)

lemma OUN_upper_lt:
     "\<lbrakk>a<A;  i < b(a);  Ord(\<Union>x<A. b(x))\<rbrakk> \<Longrightarrow> i < (\<Union>x<A. b(x))"
by (unfold OUnion_def lt_def, blast )

lemma OUN_upper_le:
     "\<lbrakk>a<A;  i\<le>b(a);  Ord(\<Union>x<A. b(x))\<rbrakk> \<Longrightarrow> i \<le> (\<Union>x<A. b(x))"
apply (unfold OUnion_def, auto)
apply (rule UN_upper_le )
apply (auto simp add: lt_def)
done

lemma Limit_OUN_eq: "Limit(i) \<Longrightarrow> (\<Union>x<i. x) = i"
by (simp add: OUnion_def Limit_Union_eq Limit_is_Ord)

(* No < version of this theorem: consider that @{term"(\<Union>i\<in>nat.i)=nat"}! *)
lemma OUN_least:
     "(\<And>x. x<A \<Longrightarrow> B(x) \<subseteq> C) \<Longrightarrow> (\<Union>x<A. B(x)) \<subseteq> C"
by (simp add: OUnion_def UN_least ltI)

lemma OUN_least_le:
     "\<lbrakk>Ord(i);  \<And>x. x<A \<Longrightarrow> b(x) \<le> i\<rbrakk> \<Longrightarrow> (\<Union>x<A. b(x)) \<le> i"
by (simp add: OUnion_def UN_least_le ltI Ord_0_le)

lemma le_implies_OUN_le_OUN:
     "\<lbrakk>\<And>x. x<A \<Longrightarrow> c(x) \<le> d(x)\<rbrakk> \<Longrightarrow> (\<Union>x<A. c(x)) \<le> (\<Union>x<A. d(x))"
by (blast intro: OUN_least_le OUN_upper_le le_Ord2 Ord_OUN)

lemma OUN_UN_eq:
     "(\<And>x. x \<in> A \<Longrightarrow> Ord(B(x)))
      \<Longrightarrow> (\<Union>z < (\<Union>x\<in>A. B(x)). C(z)) = (\<Union>x\<in>A. \<Union>z < B(x). C(z))"
by (simp add: OUnion_def)

lemma OUN_Union_eq:
     "(\<And>x. x \<in> X \<Longrightarrow> Ord(x))
      \<Longrightarrow> (\<Union>z < \<Union>(X). C(z)) = (\<Union>x\<in>X. \<Union>z < x. C(z))"
by (simp add: OUnion_def)

(*So that rule_format will get rid of this quantifier...*)
lemma atomize_oall [symmetric, rulify]:
     "(\<And>x. x<A \<Longrightarrow> P(x)) \<equiv> Trueprop (\<forall>x<A. P(x))"
by (simp add: oall_def atomize_all atomize_imp)

subsubsection \<open>universal quantifier for ordinals\<close>

lemma oallI [intro!]:
    "\<lbrakk>\<And>x. x<A \<Longrightarrow> P(x)\<rbrakk> \<Longrightarrow> \<forall>x<A. P(x)"
by (simp add: oall_def)

lemma ospec: "\<lbrakk>\<forall>x<A. P(x);  x<A\<rbrakk> \<Longrightarrow> P(x)"
by (simp add: oall_def)

lemma oallE:
    "\<lbrakk>\<forall>x<A. P(x);  P(x) \<Longrightarrow> Q;  \<not>x<A \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (simp add: oall_def, blast)

lemma rev_oallE [elim]:
    "\<lbrakk>\<forall>x<A. P(x);  \<not>x<A \<Longrightarrow> Q;  P(x) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (simp add: oall_def, blast)

(*Trival rewrite rule.  @{term"(\<forall>x<a.P)<->P"} holds only if a is not 0!*)
lemma oall_simp [simp]: "(\<forall>x<a. True) <-> True"
by blast

(*Congruence rule for rewriting*)
lemma oall_cong [cong]:
    "\<lbrakk>a=a';  \<And>x. x<a' \<Longrightarrow> P(x) <-> P'(x)\<rbrakk>
     \<Longrightarrow> oall(a, \<lambda>x. P(x)) <-> oall(a', \<lambda>x. P'(x))"
by (simp add: oall_def)

subsubsection \<open>existential quantifier for ordinals\<close>

lemma oexI [intro]:
    "\<lbrakk>P(x);  x<A\<rbrakk> \<Longrightarrow> \<exists>x<A. P(x)"
apply (simp add: oex_def, blast)
done

(*Not of the general form for such rules... *)
lemma oexCI:
   "\<lbrakk>\<forall>x<A. \<not>P(x) \<Longrightarrow> P(a);  a<A\<rbrakk> \<Longrightarrow> \<exists>x<A. P(x)"
apply (simp add: oex_def, blast)
done

lemma oexE [elim!]:
    "\<lbrakk>\<exists>x<A. P(x);  \<And>x. \<lbrakk>x<A; P(x)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
apply (simp add: oex_def, blast)
done

lemma oex_cong [cong]:
    "\<lbrakk>a=a';  \<And>x. x<a' \<Longrightarrow> P(x) <-> P'(x)\<rbrakk>
     \<Longrightarrow> oex(a, \<lambda>x. P(x)) <-> oex(a', \<lambda>x. P'(x))"
apply (simp add: oex_def cong add: conj_cong)
done

subsubsection \<open>Rules for Ordinal-Indexed Unions\<close>

lemma OUN_I [intro]: "\<lbrakk>a<i;  b \<in> B(a)\<rbrakk> \<Longrightarrow> b: (\<Union>z<i. B(z))"
by (unfold OUnion_def lt_def, blast)

lemma OUN_E [elim!]:
    "\<lbrakk>b \<in> (\<Union>z<i. B(z));  \<And>a.\<lbrakk>b \<in> B(a);  a<i\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
apply (unfold OUnion_def lt_def, blast)
done

lemma OUN_iff: "b \<in> (\<Union>x<i. B(x)) <-> (\<exists>x<i. b \<in> B(x))"
by (unfold OUnion_def oex_def lt_def, blast)

lemma OUN_cong [cong]:
    "\<lbrakk>i=j;  \<And>x. x<j \<Longrightarrow> C(x)=D(x)\<rbrakk> \<Longrightarrow> (\<Union>x<i. C(x)) = (\<Union>x<j. D(x))"
by (simp add: OUnion_def lt_def OUN_iff)

lemma lt_induct:
    "\<lbrakk>i<k;  \<And>x.\<lbrakk>x<k;  \<forall>y<x. P(y)\<rbrakk> \<Longrightarrow> P(x)\<rbrakk>  \<Longrightarrow>  P(i)"
apply (simp add: lt_def oall_def)
apply (erule conjE)
apply (erule Ord_induct, assumption, blast)
done

subsection \<open>Quantification over a class\<close>

definition
  "rall"     :: "[i\<Rightarrow>o, i\<Rightarrow>o] \<Rightarrow> o"  where
    "rall(M, P) \<equiv> \<forall>x. M(x) \<longrightarrow> P(x)"

definition
  "rex"      :: "[i\<Rightarrow>o, i\<Rightarrow>o] \<Rightarrow> o"  where
    "rex(M, P) \<equiv> \<exists>x. M(x) \<and> P(x)"

syntax
  "_rall"     :: "[pttrn, i\<Rightarrow>o, o] \<Rightarrow> o"        (\<open>(3\<forall>_[_]./ _)\<close> 10)
  "_rex"      :: "[pttrn, i\<Rightarrow>o, o] \<Rightarrow> o"        (\<open>(3\<exists>_[_]./ _)\<close> 10)
translations
  "\<forall>x[M]. P" \<rightleftharpoons> "CONST rall(M, \<lambda>x. P)"
  "\<exists>x[M]. P" \<rightleftharpoons> "CONST rex(M, \<lambda>x. P)"

subsubsection\<open>Relativized universal quantifier\<close>

lemma rallI [intro!]: "\<lbrakk>\<And>x. M(x) \<Longrightarrow> P(x)\<rbrakk> \<Longrightarrow> \<forall>x[M]. P(x)"
by (simp add: rall_def)

lemma rspec: "\<lbrakk>\<forall>x[M]. P(x); M(x)\<rbrakk> \<Longrightarrow> P(x)"
by (simp add: rall_def)

(*Instantiates x first: better for automatic theorem proving?*)
lemma rev_rallE [elim]:
    "\<lbrakk>\<forall>x[M]. P(x);  \<not> M(x) \<Longrightarrow> Q;  P(x) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (simp add: rall_def, blast)

lemma rallE: "\<lbrakk>\<forall>x[M]. P(x);  P(x) \<Longrightarrow> Q;  \<not> M(x) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by blast

(*Trival rewrite rule;   (\<forall>x[M].P)<->P holds only if A is nonempty!*)
lemma rall_triv [simp]: "(\<forall>x[M]. P) \<longleftrightarrow> ((\<exists>x. M(x)) \<longrightarrow> P)"
by (simp add: rall_def)

(*Congruence rule for rewriting*)
lemma rall_cong [cong]:
    "(\<And>x. M(x) \<Longrightarrow> P(x) <-> P'(x)) \<Longrightarrow> (\<forall>x[M]. P(x)) <-> (\<forall>x[M]. P'(x))"
by (simp add: rall_def)

subsubsection\<open>Relativized existential quantifier\<close>

lemma rexI [intro]: "\<lbrakk>P(x); M(x)\<rbrakk> \<Longrightarrow> \<exists>x[M]. P(x)"
by (simp add: rex_def, blast)

(*The best argument order when there is only one M(x)*)
lemma rev_rexI: "\<lbrakk>M(x);  P(x)\<rbrakk> \<Longrightarrow> \<exists>x[M]. P(x)"
by blast

(*Not of the general form for such rules... *)
lemma rexCI: "\<lbrakk>\<forall>x[M]. \<not>P(x) \<Longrightarrow> P(a); M(a)\<rbrakk> \<Longrightarrow> \<exists>x[M]. P(x)"
by blast

lemma rexE [elim!]: "\<lbrakk>\<exists>x[M]. P(x);  \<And>x. \<lbrakk>M(x); P(x)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (simp add: rex_def, blast)

(*We do not even have (\<exists>x[M]. True) <-> True unless A is nonempty\<And>*)
lemma rex_triv [simp]: "(\<exists>x[M]. P) \<longleftrightarrow> ((\<exists>x. M(x)) \<and> P)"
by (simp add: rex_def)

lemma rex_cong [cong]:
    "(\<And>x. M(x) \<Longrightarrow> P(x) <-> P'(x)) \<Longrightarrow> (\<exists>x[M]. P(x)) <-> (\<exists>x[M]. P'(x))"
by (simp add: rex_def cong: conj_cong)

lemma rall_is_ball [simp]: "(\<forall>x[\<lambda>z. z\<in>A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
by blast

lemma rex_is_bex [simp]: "(\<exists>x[\<lambda>z. z\<in>A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
by blast

lemma atomize_rall: "(\<And>x. M(x) \<Longrightarrow> P(x)) \<equiv> Trueprop (\<forall>x[M]. P(x))"
by (simp add: rall_def atomize_all atomize_imp)

declare atomize_rall [symmetric, rulify]

lemma rall_simps1:
     "(\<forall>x[M]. P(x) \<and> Q)   <-> (\<forall>x[M]. P(x)) \<and> ((\<forall>x[M]. False) | Q)"
     "(\<forall>x[M]. P(x) | Q)   <-> ((\<forall>x[M]. P(x)) | Q)"
     "(\<forall>x[M]. P(x) \<longrightarrow> Q) <-> ((\<exists>x[M]. P(x)) \<longrightarrow> Q)"
     "(\<not>(\<forall>x[M]. P(x))) <-> (\<exists>x[M]. \<not>P(x))"
by blast+

lemma rall_simps2:
     "(\<forall>x[M]. P \<and> Q(x))   <-> ((\<forall>x[M]. False) | P) \<and> (\<forall>x[M]. Q(x))"
     "(\<forall>x[M]. P | Q(x))   <-> (P | (\<forall>x[M]. Q(x)))"
     "(\<forall>x[M]. P \<longrightarrow> Q(x)) <-> (P \<longrightarrow> (\<forall>x[M]. Q(x)))"
by blast+

lemmas rall_simps [simp] = rall_simps1 rall_simps2

lemma rall_conj_distrib:
    "(\<forall>x[M]. P(x) \<and> Q(x)) <-> ((\<forall>x[M]. P(x)) \<and> (\<forall>x[M]. Q(x)))"
by blast

lemma rex_simps1:
     "(\<exists>x[M]. P(x) \<and> Q) <-> ((\<exists>x[M]. P(x)) \<and> Q)"
     "(\<exists>x[M]. P(x) | Q) <-> (\<exists>x[M]. P(x)) | ((\<exists>x[M]. True) \<and> Q)"
     "(\<exists>x[M]. P(x) \<longrightarrow> Q) <-> ((\<forall>x[M]. P(x)) \<longrightarrow> ((\<exists>x[M]. True) \<and> Q))"
     "(\<not>(\<exists>x[M]. P(x))) <-> (\<forall>x[M]. \<not>P(x))"
by blast+

lemma rex_simps2:
     "(\<exists>x[M]. P \<and> Q(x)) <-> (P \<and> (\<exists>x[M]. Q(x)))"
     "(\<exists>x[M]. P | Q(x)) <-> ((\<exists>x[M]. True) \<and> P) | (\<exists>x[M]. Q(x))"
     "(\<exists>x[M]. P \<longrightarrow> Q(x)) <-> (((\<forall>x[M]. False) | P) \<longrightarrow> (\<exists>x[M]. Q(x)))"
by blast+

lemmas rex_simps [simp] = rex_simps1 rex_simps2

lemma rex_disj_distrib:
    "(\<exists>x[M]. P(x) | Q(x)) <-> ((\<exists>x[M]. P(x)) | (\<exists>x[M]. Q(x)))"
by blast

subsubsection\<open>One-point rule for bounded quantifiers\<close>

lemma rex_triv_one_point1 [simp]: "(\<exists>x[M]. x=a) <-> ( M(a))"
by blast

lemma rex_triv_one_point2 [simp]: "(\<exists>x[M]. a=x) <-> ( M(a))"
by blast

lemma rex_one_point1 [simp]: "(\<exists>x[M]. x=a \<and> P(x)) <-> ( M(a) \<and> P(a))"
by blast

lemma rex_one_point2 [simp]: "(\<exists>x[M]. a=x \<and> P(x)) <-> ( M(a) \<and> P(a))"
by blast

lemma rall_one_point1 [simp]: "(\<forall>x[M]. x=a \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
by blast

lemma rall_one_point2 [simp]: "(\<forall>x[M]. a=x \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
by blast

subsubsection\<open>Sets as Classes\<close>

definition
  setclass :: "[i,i] \<Rightarrow> o"       (\<open>##_\<close> [40] 40)  where
   "setclass(A) \<equiv> \<lambda>x. x \<in> A"

lemma setclass_iff [simp]: "setclass(A,x) <-> x \<in> A"
by (simp add: setclass_def)

lemma rall_setclass_is_ball [simp]: "(\<forall>x[##A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
by auto

lemma rex_setclass_is_bex [simp]: "(\<exists>x[##A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
by auto

ML
\<open>
val Ord_atomize =
  atomize ([(\<^const_name>\<open>oall\<close>, @{thms ospec}), (\<^const_name>\<open>rall\<close>, @{thms rspec})] @
    ZF_conn_pairs, ZF_mem_pairs);
\<close>
declaration \<open>fn _ =>
  Simplifier.map_ss (Simplifier.set_mksimps (fn ctxt =>
    map mk_eq o Ord_atomize o Variable.gen_all ctxt))
\<close>

text \<open>Setting up the one-point-rule simproc\<close>

simproc_setup defined_rex ("\<exists>x[M]. P(x) \<and> Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_Bex
    (fn ctxt => unfold_tac ctxt @{thms rex_def})
\<close>

simproc_setup defined_rall ("\<forall>x[M]. P(x) \<longrightarrow> Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_Ball
    (fn ctxt => unfold_tac ctxt @{thms rall_def})
\<close>

end


theory Ex5_4
  imports Main
begin

type_synonym intervals = "(nat \<times> nat) list"

type_synonym ntup = "nat \<times> nat"

fun inv2 :: "nat \<Rightarrow> intervals \<Rightarrow> bool" where
"inv2 _ [] = True"|
"inv2 n ((x,y)#xs) = (n \<le>  x \<and>  x \<le> y \<and> inv2 (y + 2) xs)"

definition inv :: "intervals \<Rightarrow> bool" where
"inv ls = inv2 0 ls"

fun set_of :: "intervals \<Rightarrow> nat set" where
"set_of [] = {}"|
"set_of ((x,y)#xs) = {n. x \<le> n \<and> n  \<le>  y} \<union> set_of xs"

primrec add :: "ntup \<Rightarrow> intervals  \<Rightarrow> intervals" where
"add val [] = [val]"|
"add nt (x#xs) = (if snd nt < fst x - 1 then nt # x# xs  else (if snd x < fst nt - 1 then x # add nt xs else add (min (fst nt) (fst x), max (snd nt)(snd x)) xs ) ) "
(*
fun rem :: "ntup \<Rightarrow> intervals \<Rightarrow> intervals" where
"rem _ [] = []"|
"rem (s,e) ((x,y)#xs) = (if (s = x) \<and> (e = y) then xs else (x,y) # rem (s,e) xs)"
*)
lemma inv2_monotone : "inv2 m ins \<Longrightarrow> n \<le> m \<Longrightarrow> inv2 n ins"
proof (induction ins arbitrary : m)
  case Nil
  then show ?case by simp
next
  case (Cons a ins)
  have tmp:"inv2 n ins"
  proof -
    have tmp:"inv2 m (a#ins) = (m \<le> fst a \<and> fst a \<le> snd a \<and> inv2 (snd a + 2) ins)" by (subst prod.collapse[symmetric], subst inv2.simps(2), rule refl)
    with Cons(2) have tmp1:"inv2 (snd a + 2) ins" by simp
    have "n \<le> snd a + 2" using Cons.prems tmp by linarith
    with Cons(1)[of "snd a + 2"] tmp1 show ?thesis by simp
  qed
  show ?case using  Cons(3) Cons(2) inv2.simps(2) tmp le_trans[of n m "fst a"]  prod.collapse[symmetric, of a]  by metis
qed

declare inv_def[simp]

lemma helper:"inv2 a ins \<Longrightarrow> i \<le> j \<Longrightarrow> a \<le> i  \<Longrightarrow> inv2 a (add (i,j) ins)"
proof (induction ins arbitrary : a i j)
  case Nil
  then show ?case by simp
next
  case (Cons aa ins)
  assume hyp1:"\<And>a i j. inv2 a ins \<Longrightarrow> i \<le> j \<Longrightarrow> a \<le> i  \<Longrightarrow> inv2 a (add (i, j) ins)"
  and hyp2:"inv2 a (aa # ins)"
  and hyp3:"i \<le> j"
  and hyp4:"a \<le> i"

  let ?faa = "fst aa"
  and ?saa = "snd aa"

  show ?case
  proof (cases "j < fst aa - 1")
    case True
    hence tmp:"j + 2 \<le> fst aa" by simp
    have "inv2 a (add (i, j) (aa # ins)) = inv2 a ((i,j) # aa # ins)" using True inv2.simps hyp3 prod.collapse[of aa , symmetric]  add.simps(2) prod.sel(2)[of i j] by simp
    also have "\<dots>  = inv2 (j + 2) (aa # ins)" using hyp3 hyp4 by simp
    also have "\<dots> = inv2 a (aa # ins)" using hyp2 tmp inv2.simps(2) prod.collapse[of aa , symmetric]  hyp4 by metis
    finally show ?thesis using hyp2 by simp
  next
    case False
    assume c1:"\<not> j < fst aa - 1"
    then show ?thesis
    proof (cases "snd aa < i- 1")
      case True
      from hyp2 have "inv2 (snd aa + 2) ins" using inv2.simps(2) prod.collapse[of aa, symmetric] by metis
      with hyp1[of "snd aa + 2" i j] hyp3 True have tmp:"inv2 (snd aa + 2) (add (i, j) ins)" by simp
      have "inv2 a (add (i, j) (aa # ins)) = inv2 a (aa # add (i,j) ins)" using False True prod.collapse[of aa , symmetric] prod.sel add.simps(2) by simp
      also have "\<dots> = inv2 (snd aa + 2) (add (i,j) ins)" using hyp2 inv2.simps(2) prod.collapse[of aa , symmetric]  by metis
      finally show ?thesis using tmp by simp
    next
      case False

      have tmp:"min i (fst aa) \<le> max j (snd aa)" using hyp3 hyp2 by auto

      have tmp2:"a \<le> min i (fst aa)" using hyp2 hyp4 min_def prod.collapse[of aa , symmetric] le_trans inv2.simps by metis

      have "a \<le> snd aa + 2" using hyp2 prod.collapse[symmetric , of aa]  inv2.simps(2) le_trans trans_le_add1 by metis

      hence "inv2 a ins"  using hyp2 inv2_monotone inv2.simps(2) prod.collapse[of aa, symmetric] by metis

      hence tmp3:"inv2 a (add (min i (fst aa), max j (snd aa)) ins)" using hyp1[of a "min i (fst aa)" "max j (snd aa)"] tmp tmp2 by simp

      have "inv2 a (add (i, j) (aa # ins)) = inv2 a (add (min  i (fst aa), max j (snd aa)) ins)"
        by (subst add.simps , subst prod.sel(2), subst c1, subst if_False, subst prod.sel(1), subst False , subst if_False, simp)
      then show ?thesis using tmp3 by simp
    qed
  qed
qed

theorem inv_add : "\<lbrakk> i \<le> j ; inv ins \<rbrakk> \<Longrightarrow> inv (add (i,j) ins)" using helper[of 0 ins i j] by simp

lemma helper2:"set_of (xs @ ys) = set_of xs \<union> set_of ys"  by (induction xs ;auto)

theorem set_of_add:
  "\<lbrakk> i \<le> j; inv ins \<rbrakk> \<Longrightarrow> set_of (add (i,j) ins) = set_of [(i,j)] \<union> set_of ins"
proof (induction ins)
  case Nil
  then show ?case by simp
next
  case (Cons aa ins)
  then show ?case
  proof (cases "j < fst aa - 1")
    case True
    then show ?thesis
  next
    case False
    then show ?thesis sorry
qed

qed


section \<open>Power sum polynomials\<close>
(*
  File:     Power_Sum_Polynomials.thy
  Author:   Manuel Eberl, TU München
*)
theory Power_Sum_Polynomials
imports
  "Symmetric_Polynomials.Symmetric_Polynomials"
  "HOL-Computational_Algebra.Field_as_Ring"
  Power_Sum_Polynomials_Library
begin

subsection \<open>Definition\<close>

text \<open>
  For $n$ indeterminates $X_1,\ldots,X_n$, we define the $k$-th power sum polynomial as
  \[p_k(X_1, \ldots, X_n) = X_1^k + \ldots + X_n^k\ .\]
\<close>
lift_definition powsum_mpoly_aux :: "nat set \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a :: {semiring_1,zero_neq_one}" is
  "\<lambda>X k mon. if infinite X \<or> k = 0 \<and> mon \<noteq> 0 then 0
             else if k = 0 \<and> mon = 0 then of_nat (card X)
             else if finite X \<and> (\<exists>x\<in>X. mon = Poly_Mapping.single x k) then 1 else 0"
  by auto

lemma lookup_powsum_mpoly_aux:
  "Poly_Mapping.lookup (powsum_mpoly_aux X k) mon =
     (if infinite X \<or> k = 0 \<and> mon \<noteq> 0 then 0
             else if k = 0 \<and> mon = 0 then of_nat (card X)
             else if finite X \<and> (\<exists>x\<in>X. mon = Poly_Mapping.single x k) then 1 else 0)"
  by transfer' simp

lemma lookup_sym_mpoly_aux_monom_singleton [simp]:
  assumes "finite X" "x \<in> X" "k > 0"
  shows   "Poly_Mapping.lookup (powsum_mpoly_aux X k) (Poly_Mapping.single x k) = 1"
  using assms by (auto simp: lookup_powsum_mpoly_aux)

lemma lookup_sym_mpoly_aux_monom_singleton':
  assumes "finite X" "k > 0"
  shows   "Poly_Mapping.lookup (powsum_mpoly_aux X k) (Poly_Mapping.single x k) = (if x \<in> X then 1 else 0)"
  using assms by (auto simp: lookup_powsum_mpoly_aux)

lemma keys_powsum_mpoly_aux: "m \<in> keys (powsum_mpoly_aux A k) \<Longrightarrow> keys m \<subseteq> A"
  by transfer' (auto split: if_splits simp: keys_monom_of_set)

lift_definition powsum_mpoly :: "nat set \<Rightarrow> nat \<Rightarrow> 'a :: {semiring_1,zero_neq_one} mpoly" is
  "powsum_mpoly_aux" .

lemma vars_powsum_mpoly_subset: "vars (powsum_mpoly A k) \<subseteq> A"
  using keys_powsum_mpoly_aux by (auto simp: vars_def powsum_mpoly.rep_eq)

lemma powsum_mpoly_infinite: "\<not>finite A \<Longrightarrow> powsum_mpoly A k = 0"
  by (transfer, transfer) auto

lemma coeff_powsum_mpoly:
  "MPoly_Type.coeff (powsum_mpoly X k) mon =
     (if infinite X \<or> k = 0 \<and> mon \<noteq> 0 then 0
             else if k = 0 \<and> mon = 0 then of_nat (card X)
             else if finite X \<and> (\<exists>x\<in>X. mon = Poly_Mapping.single x k) then 1 else 0)"
  by transfer' (simp add: lookup_powsum_mpoly_aux)

lemma coeff_powsum_mpoly_0_right:
  "MPoly_Type.coeff (powsum_mpoly X 0) mon = (if mon = 0 then of_nat (card X) else 0)"
  by transfer' (auto simp add: lookup_powsum_mpoly_aux)

lemma coeff_powsum_mpoly_singleton:
  assumes "finite X" "k > 0"
  shows   "MPoly_Type.coeff (powsum_mpoly X k) (Poly_Mapping.single x k) = (if x \<in> X then 1 else 0)"
  using assms by transfer' (simp add: lookup_powsum_mpoly_aux)

lemma coeff_powsum_mpoly_singleton_eq_1 [simp]:
  assumes "finite X" "x \<in> X" "k > 0"
  shows   "MPoly_Type.coeff (powsum_mpoly X k) (Poly_Mapping.single x k) = 1"
  using assms by (simp add: coeff_powsum_mpoly_singleton)

lemma coeff_powsum_mpoly_singleton_eq_0 [simp]:
  assumes "finite X" "x \<notin> X" "k > 0"
  shows   "MPoly_Type.coeff (powsum_mpoly X k) (Poly_Mapping.single x k) = 0"
  using assms by (simp add: coeff_powsum_mpoly_singleton)

lemma powsum_mpoly_0 [simp]: "powsum_mpoly X 0 = of_nat (card X)"
  by (intro mpoly_eqI ext) (auto simp: coeff_powsum_mpoly_0_right of_nat_mpoly_eq mpoly_coeff_Const)

lemma powsum_mpoly_empty [simp]: "powsum_mpoly {} k = 0"
  by (intro mpoly_eqI) (auto simp: coeff_powsum_mpoly)

lemma powsum_mpoly_altdef: "powsum_mpoly X k = (\<Sum>x\<in>X. monom (Poly_Mapping.single x k) 1)"
proof (cases "finite X")
  case [simp]: True
  show ?thesis
  proof (cases "k = 0")
    case True
    thus ?thesis by auto
  next
    case False
    show ?thesis
    proof (intro mpoly_eqI, goal_cases)
      case (1 mon)
      show ?case using False
        by (cases "\<exists>x\<in>X. mon = Poly_Mapping.single x k")
           (auto simp: coeff_powsum_mpoly coeff_monom when_def)
    qed
  qed
qed (auto simp: powsum_mpoly_infinite)

text \<open>
  Power sum polynomials are symmetric:
\<close>
lemma symmetric_powsum_mpoly [intro]:
  assumes "A \<subseteq> B"
  shows   "symmetric_mpoly A (powsum_mpoly B k)"
  unfolding powsum_mpoly_altdef
proof (rule symmetric_mpoly_symmetric_sum)
  fix x \<pi>
  assume "x \<in> B" "\<pi> permutes A"
  thus "mpoly_map_vars \<pi> (MPoly_Type.monom (Poly_Mapping.single x k) 1) =
        MPoly_Type.monom (Poly_Mapping.single (\<pi> x) k) 1"
    using assms by (auto simp: mpoly_map_vars_monom permutes_bij permutep_single
                               bij_imp_bij_inv permutes_inv_inv)
qed (use assms in \<open>auto simp: permutes_subset\<close>)

lemma insertion_powsum_mpoly [simp]: "insertion f (powsum_mpoly X k) = (\<Sum>i\<in>X. f i ^ k)"
  unfolding powsum_mpoly_altdef insertion_sum insertion_single by simp

lemma powsum_mpoly_nz:
  assumes "finite X" "X \<noteq> {}" "k > 0"
  shows   "(powsum_mpoly X k :: 'a :: {semiring_1, zero_neq_one} mpoly) \<noteq> 0"
proof -
  from assms obtain x where "x \<in> X" by auto
  hence "coeff (powsum_mpoly X k) (Poly_Mapping.single x k) = (1 :: 'a)"
    using assms by (auto simp: coeff_powsum_mpoly)
  thus ?thesis by auto
qed

lemma powsum_mpoly_eq_0_iff:
  assumes "k > 0"
  shows   "powsum_mpoly X k = 0 \<longleftrightarrow> infinite X \<or> X = {}"
  using assms powsum_mpoly_nz[of X k] by (auto simp: powsum_mpoly_infinite)

subsection \<open>The Girard--Newton Theorem\<close>

text \<open>
  The following is a nice combinatorial proof of the Girard--Newton Theorem due to
  Doron Zeilberger~\cite{zeilberger}.

  The precise statement is this:

  Let $e_k$ denote the $k$-th elementary symmetric polynomial in $X_1,\ldots,X_n$.
  This is the sum of all monomials that can be formed by taking the product of $k$
  distinct variables.

  Next, let $p_k = X_1^k + \ldots + X_n^k$ denote that $k$-th symmetric power sum polynomial
  in $X_1,\ldots,X_n$.

  Then the following equality holds:
  \[(-1)^k k e_k + \sum_{i=0}^{k-1} (-1)^i e_i p_{k-i}\]
\<close>
theorem Girard_Newton:
  assumes "finite X"
  shows   "(-1) ^ k * of_nat k * sym_mpoly X k +
           (\<Sum>i<k. (-1) ^ i * sym_mpoly X i * powsum_mpoly X (k - i)) =
             (0 :: 'a :: comm_ring_1 mpoly)"
  (is "?lhs = 0")
proof -
  write Poly_Mapping.single ("sng")

  define n where "n = card X"
  define \ :: "(nat set \<times> nat) set"
    where "\ = {(A, j). A \<subseteq> X \<and> card A \<le> k \<and> j \<in> X \<and> (card A = k \<longrightarrow> j \<in> A)}"
  define \1 :: "(nat set \<times> nat) set"
    where "\1 = {A\<in>Pow X. card A < k} \<times> X"
  define \2 :: "(nat set \<times> nat) set"
    where "\2 = (SIGMA A:{A\<in>Pow X. card A = k}. A)"

  have \_split: "\ = \1 \<union> \2" "\1 \<inter> \2 = {}"
    by (auto simp: \_def \1_def \2_def)
  have [intro]: "finite \1" "finite \2"
    using assms finite_subset[of _ X] by (auto simp: \1_def \2_def intro!: finite_SigmaI)
  have [intro]: "finite \"
    by (subst \_split) auto

  \<comment> \<open>
    We define a `weight' function \<open>w\<close> from \<open>\\<close> to the ring of polynomials as
    \[w(A,j) = (-1)^{|A|} x_j^{k-|A|} \prod_{i\in A} x_i\ .\]
  \<close>
  define w :: "nat set \<times> nat \<Rightarrow> 'a mpoly"
    where "w = (\<lambda>(A, j). monom (monom_of_set A + sng j (k - card A)) ((-1) ^ card A))"

  \<comment> \<open>The sum of these weights over all of \<open>\\<close> is precisely the sum that we want to show equals 0:\<close>
  have "?lhs = (\<Sum>x\<in>\. w x)"
  proof -
    have "(\<Sum>x\<in>\. w x) = (\<Sum>x\<in>\1. w x) + (\<Sum>x\<in>\2. w x)"
      by (subst \_split, subst sum.union_disjoint, use \_split(2) in auto)

    also have "(\<Sum>x\<in>\1. w x) = (\<Sum>i<k. (-1) ^ i * sym_mpoly X i * powsum_mpoly X (k - i))"
    proof -
      have "(\<Sum>x\<in>\1. w x) = (\<Sum>A | A \<subseteq> X \<and> card A < k. \<Sum>j\<in>X. w (A, j))"
        using assms by (subst sum.Sigma) (auto simp: \1_def)
      also have "\<dots> = (\<Sum>A | A \<subseteq> X \<and> card A < k. \<Sum>j\<in>X.
                        monom (monom_of_set A) ((-1) ^ card A) * monom (sng j (k - card A)) 1)"
        unfolding w_def by (intro sum.cong) (auto simp: mult_monom)
      also have "\<dots> = (\<Sum>A | A \<subseteq> X \<and> card A < k. monom (monom_of_set A) ((-1) ^ card A) *
                        powsum_mpoly X (k - card A))"
        by (simp add: sum_distrib_left powsum_mpoly_altdef)
      also have "\<dots> = (\<Sum>(i,A) \<in> (SIGMA i:{..<k}. {A. A \<subseteq> X \<and> card A = i}).
                        monom (monom_of_set A) ((-1) ^ i) * powsum_mpoly X (k - i))"
        by (rule sum.reindex_bij_witness[of _ snd "\<lambda>A. (card A, A)"]) auto
      also have "\<dots> = (\<Sum>i<k. \<Sum>A | A \<subseteq> X \<and> card A = i.
                        monom (monom_of_set A) 1 * monom 0 ((-1) ^ i) * powsum_mpoly X (k - i))"
        using assms by (subst sum.Sigma) (auto simp: mult_monom)
      also have "\<dots> = (\<Sum>i<k. (-1) ^ i * sym_mpoly X i * powsum_mpoly X (k - i))"
        by (simp add: sum_distrib_left sum_distrib_right mpoly_monom_0_eq_Const
                      mpoly_Const_power mpoly_Const_uminus algebra_simps sym_mpoly_altdef)
      finally show ?thesis .
    qed

    also have "(\<Sum>x\<in>\2. w x) = (-1) ^ k * of_nat k * sym_mpoly X k"
    proof -
      have "(\<Sum>x\<in>\2. w x) = (\<Sum>(A,j)\<in>\2. monom (monom_of_set A) ((- 1) ^ k))"
        by (intro sum.cong) (auto simp: \2_def w_def mpoly_monom_0_eq_Const intro!: sum.cong)
      also have "\<dots> = (\<Sum>A | A \<subseteq> X \<and> card A = k. \<Sum>j\<in>A. monom (monom_of_set A) ((- 1) ^ k))"
        using assms finite_subset[of _ X] by (subst sum.Sigma) (auto simp: \2_def)
      also have "(\<lambda>A. monom (monom_of_set A) ((- 1) ^ k) :: 'a mpoly) =
                   (\<lambda>A. monom 0 ((-1) ^ k) * monom (monom_of_set A) 1)"
        by (auto simp: fun_eq_iff mult_monom)
      also have "monom 0 ((-1) ^ k) = (-1) ^ k"
        by (auto simp: mpoly_monom_0_eq_Const mpoly_Const_power mpoly_Const_uminus)
      also have "(\<Sum>A | A \<subseteq> X \<and> card A = k. \<Sum>j\<in>A. (- 1) ^ k * monom (monom_of_set A) 1) =
                   ((-1) ^ k * of_nat k * sym_mpoly X k :: 'a mpoly)"
        by (auto simp: sum_distrib_left sum_distrib_right mult_ac sym_mpoly_altdef)
      finally show ?thesis .
    qed

    finally show ?thesis by (simp add: algebra_simps)
  qed

  \<comment> \<open>Next, we show that the weights sum to 0:\<close>
  also have "(\<Sum>x\<in>\. w x) = 0"
  proof -
    \<comment> \<open>We define a function \<open>T\<close> that is a involutory permutation of \<open>\\<close>.
        To be more precise, it bijectively maps those elements \<open>(A,j)\<close> of \<open>\\<close> with \<open>j \<in> A\<close>
        to those where \<open>j \<notin> A\<close> and the other way round. `Involutory' means that \<open>T\<close> is its
        own inverse function, i.\,e.\ $T(T(x)) = x$.\<close>
    define T :: "nat set \<times> nat \<Rightarrow> nat set \<times> nat"
      where "T = (\<lambda>(A, j). if j \<in> A then (A - {j}, j) else (insert j A, j))"
    have [simp]: "T (T x) = x" for x
      by (auto simp: T_def split: prod.splits)
    have [simp]: "T x \<in> \" if "x \<in> \" for x
    proof -
      have [simp]: "n \<le> n - Suc 0 \<longleftrightarrow> n = 0" for n
        by auto
      show ?thesis using that assms finite_subset[of _ X]
        by (auto simp: T_def \_def split: prod.splits)
    qed
    have "snd (T x) \<in> fst (T x) \<longleftrightarrow> snd x \<notin> fst x" if "x \<in> \" for x
      by (auto simp: T_def split: prod.splits)
    hence bij: "bij_betw T {x\<in>\. snd x \<in> fst x} {x\<in>\. snd x \<notin> fst x}"
      by (intro bij_betwI[of _ _ _ T]) auto

    \<comment>\<open>Crucially, we show that \<^term>\<open>T\<close> flips the weight of each element:\<close>
    have [simp]: "w (T x) = -w x" if "x \<in> \" for x
    proof -
      obtain A j where [simp]: "x = (A, j)" by force

      \<comment> \<open>Since \<^term>\<open>T\<close> is an involution, we can assume w.\,l.\,o.\,g.\ that \<open>j \<in> A\<close>:\<close>
      have aux: "w (T (A, j)) = - w (A, j)" if "(A, j) \<in> \" "j \<in> A" for j A
      proof -
        from that have [simp]: "j \<in> A" "A \<subseteq> X" and "k > 0"
          using finite_subset[OF _ assms, of A] by (auto simp: \_def intro!: Nat.gr0I)
        have [simp]: "finite A"
          using finite_subset[OF _ assms, of A] by auto
        from that have "card A \<le> k"
          by (auto simp: \_def)

        have card: "card A = Suc (card (A - {j}))"
          using card.remove[of A j] by auto
        hence card_less: "card (A - {j}) < card A" by linarith

        have "w (T (A, j)) = monom (monom_of_set (A - {j}) + sng j (k - card (A - {j})))
                         ((- 1) ^ card (A - {j}))" by (simp add: w_def T_def)
        also have "(- 1) ^ card (A - {j}) = ((- 1) ^ Suc (Suc (card (A - {j}))) :: 'a)"
          by simp
        also have "Suc (card (A - {j})) = card A"
          using card by simp
        also have "k - card (A - {j}) = Suc (k - card A)"
          using \<open>k > 0\<close> \<open>card A \<le> k\<close> card_less by (subst card) auto
        also have "monom_of_set (A - {j}) + sng j (Suc (k - card A)) =
                   monom_of_set A + sng j (k - card A)"
          by (transfer fixing: A j k) (auto simp: fun_eq_iff)
        also have "monom \<dots> ((-1)^ Suc (card A)) = -w (A, j)"
          by (simp add: w_def monom_uminus)
        finally show ?thesis .
      qed

      show ?thesis
      proof (cases "j \<in> A")
        case True
        with aux[of A j] that show ?thesis by auto
      next
        case False
        hence "snd (T x) \<in> fst (T x)"
          by (auto simp: T_def split: prod.splits)
        with aux[of "fst (T x)" "snd (T x)"] that show ?thesis by auto
      qed
    qed

    text \<open>
      We can now show fairly easily that the sum is equal to zero.
    \<close>
    have *: "\ = {x\<in>\. snd x \<in> fst x} \<union> {x\<in>\. snd x \<notin> fst x}"
      by auto
    have "(\<Sum>x\<in>\. w x) = (\<Sum>x | x \<in> \ \<and> snd x \<in> fst x. w x) + (\<Sum>x | x \<in> \ \<and> snd x \<notin> fst x. w x)"
      using \<open>finite \\<close> by (subst *, subst sum.union_disjoint) auto
    also have "(\<Sum>x | x \<in> \ \<and> snd x \<notin> fst x. w x) = (\<Sum>x | x \<in> \ \<and> snd x \<in> fst x. w (T x))"
      using sum.reindex_bij_betw[OF bij, of w] by simp
    also have "\<dots> = -(\<Sum>x | x \<in> \ \<and> snd x \<in> fst x. w x)"
      by (simp add: sum_negf)
    finally show "(\<Sum>x\<in>\. w x) = 0"
      by simp
  qed

  finally show ?thesis .
qed

text \<open>
  The following variant of the theorem holds for \<open>k > n\<close>. Note that this is now a
  linear recurrence relation with constant coefficients for $p_k$ in terms of
  $e_0, \ldots, e_n$.
\<close>
corollary Girard_Newton':
  assumes "finite X" and "k > card X"
  shows   "(\<Sum>i\<le>card X. (-1) ^ i * sym_mpoly X i * powsum_mpoly X (k - i)) =
             (0 :: 'a :: comm_ring_1 mpoly)"
proof -
  have "(0 :: 'a mpoly) = (\<Sum>i<k. (- 1) ^ i * sym_mpoly X i * powsum_mpoly X (k - i))"
    using Girard_Newton[of X k] assms by simp
  also have "\<dots> = (\<Sum>i\<le>card X. (- 1) ^ i * sym_mpoly X i * powsum_mpoly X (k - i))"
    using assms by (intro sum.mono_neutral_right) auto
  finally show ?thesis ..
qed

text \<open>
  The following variant is the Newton--Girard Theorem solved for $e_k$, giving us
  an explicit way to determine $e_k$ from $e_0, \ldots, e_{k-1}$ and $p_1, \ldots, p_k$:
\<close>
corollary sym_mpoly_recurrence:
  assumes k: "k > 0" and "finite X"
  shows   "(sym_mpoly X k :: 'a :: field_char_0 mpoly) =
             -smult (1 / of_nat k) (\<Sum>i=1..k. (-1) ^ i * sym_mpoly X (k - i) * powsum_mpoly X i)"
proof -
  define e p :: "nat \<Rightarrow> 'a mpoly" where [simp]: "e = sym_mpoly X" "p = powsum_mpoly X"
  have *: "0 = (-1) ^ k * of_nat k * e k +
              (\<Sum>i<k. (- 1) ^ i * e i * p (k - i) :: 'a mpoly)"
    using Girard_Newton[of X k] assms by simp

  have "0 = (-1) ^ k * smult (1 / of_nat k) (0 :: 'a mpoly)"
    by simp
  also have "\<dots> = smult (1 / of_nat k) (of_nat k) * e k +
                  smult (1 / of_nat k) (\<Sum>i<k. (-1)^(k+i) * e i * p (k - i))"
    unfolding smult_conv_mult
    using k by (subst *) (simp add: power_add sum_distrib_left sum_distrib_right field_simps
                               del: div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1)
  also have "smult (1 / of_nat k :: 'a) (of_nat k) = 1"
    using k by (simp add: of_nat_monom smult_conv_mult mult_monom del: monom_of_nat)
  also have "(\<Sum>i<k. (-1) ^ (k+i) * e i * p (k - i)) = (\<Sum>i=1..k. (-1) ^ i * e (k-i) * p i)"
    by (intro sum.reindex_bij_witness[of _ "\<lambda>i. k - i" "\<lambda>i. k - i"])
       (auto simp: minus_one_power_iff)
  finally show ?thesis unfolding e_p_def by algebra
qed

text \<open>
  Analogously, the following is the theorem solved for $p_k$, giving us a
  way to determine $p_k$ from $e_0, \ldots, e_k$ and $p_1, \ldots, p_{k-1}$:
\<close>
corollary powsum_mpoly_recurrence:
  assumes k: "k > 0" and X: "finite X"
  shows   "(powsum_mpoly X k :: 'a :: comm_ring_1 mpoly) =
             (-1) ^ (k + 1) * of_nat k * sym_mpoly X k -
             (\<Sum>i=1..<k. (-1) ^ i * sym_mpoly X i * powsum_mpoly X (k - i))"
proof -
  define e p :: "nat \<Rightarrow> 'a mpoly" where [simp]: "e = sym_mpoly X" "p = powsum_mpoly X"
  have *: "0 = (-1) ^ k * of_nat k * e k +
                 (\<Sum>i<k. (-1) ^ i * e i * p (k - i) :: 'a mpoly)"
    using Girard_Newton[of X k] assms by simp
  also have "{..<k} = insert 0 {1..<k}"
    using assms by auto
  finally have "(-1) ^ k * of_nat k * e k + (\<Sum>i=1..<k. (-1) ^ i * e i * p (k - i)) + p k = 0"
    using assms by (simp add: algebra_simps)
  from add.inverse_unique[OF this] show ?thesis by simp
qed

text \<open>
  Again, if we assume $k > n$, the above takes a much simpler form and is, in fact,
  a linear recurrence with constant coefficients:
\<close>
lemma powsum_mpoly_recurrence':
  assumes k: "k > card X" and X: "finite X"
  shows   "(powsum_mpoly X k :: 'a :: comm_ring_1 mpoly) =
             -(\<Sum>i=1..card X. (-1) ^ i * sym_mpoly X i * powsum_mpoly X (k - i))"
proof -
  define e p :: "nat \<Rightarrow> 'a mpoly" where [simp]: "e = sym_mpoly X" "p = powsum_mpoly X"
  have "p k = (-1) ^ (k + 1) * of_nat k * e k - (\<Sum>i=1..<k. (-1) ^ i * e i * p (k - i))"
    unfolding e_p_def using assms by (intro powsum_mpoly_recurrence) auto
  also have "\<dots> = -(\<Sum>i=1..<k. (-1) ^ i * e i * p (k - i))"
    using assms by simp
  also have "(\<Sum>i=1..<k. (-1) ^ i * e i * p (k - i)) = (\<Sum>i=1..card X. (-1) ^ i * e i * p (k - i))"
    using assms by (intro sum.mono_neutral_right) auto
  finally show ?thesis by simp
qed

end


theory Lists1_5
imports Main
begin

primrec occurs:: "'a \<Rightarrow> 'a list \<Rightarrow> nat"
where
  "occurs x [] = 0"
| "occurs x (y#ys) = (if x = y then Suc (occurs x ys) else (occurs x ys))"

value "occurs 1 [1,2,3,4,1,3::int]"

lemma occurs_append: "occurs x (ys @ zs) = (occurs x ys) + (occurs x zs)"
  apply (induct ys)
  apply auto
done

lemma "occurs x ys = occurs x (rev ys)"
  apply (induct ys)
  apply (auto simp add:occurs_append)
done

lemma "occurs x ys \<le> length ys"
  apply (induct ys)
  apply auto
done

lemma "occurs a (map f xs) = occurs (f a) xs"
  quickcheck
oops

lemma "occurs a (filter P xs) = (if P a then occurs a xs else 0)"
  apply (induct xs)
  apply auto
done

primrec remDups :: "'a list \<Rightarrow> 'a list"
where
  "remDups [] = []"
| "remDups (x#xs) = (if 0 < occurs x xs then remDups xs else (x#(remDups xs)))"

value "remDups [1,2,3,4,5::int,1,2,5]"

(* different from text *)
lemma occurs_remdups: "occurs x (remDups xs) = (if ((occurs x xs) = 0) then 0 else 1)"
  apply (induct xs)
  apply auto
done

(* different from text *)
primrec unique:: "'a list \<Rightarrow> bool"
where
  "unique [] = True"
| "unique (x#xs) = (if 0 < occurs x xs then False else unique xs)"

value "unique []"
value "unique [1::int,2,3]"
value "unique [1::int,1,2,3]"

lemma "unique (remDups xs)"
  apply (induct xs)
  apply (auto simp add:occurs_remdups)
done

end


(*  Title:       Square Matrices
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

section \<open> Square Matrices \<close>

text\<open> The general solution for affine systems of ODEs involves the exponential function.
Unfortunately, this operation is only available in Isabelle for the type class ``banach''.
Hence, we define a type of square matrices and prove that it is an instance of this class.\<close>

theory SQ_MTX
  imports MTX_Norms

begin

subsection \<open> Definition \<close>

typedef 'm sq_mtx = "UNIV::(real^'m^'m) set"
  morphisms to_vec to_mtx by simp

declare to_mtx_inverse [simp]
    and to_vec_inverse [simp]

setup_lifting type_definition_sq_mtx

lift_definition sq_mtx_ith :: "'m sq_mtx \<Rightarrow> 'm \<Rightarrow> (real^'m)" (infixl "$$" 90) is "($)" .

lift_definition sq_mtx_vec_mult :: "'m sq_mtx \<Rightarrow> (real^'m) \<Rightarrow> (real^'m)" (infixl "*\<^sub>V" 90) is "(*v)" .

lift_definition vec_sq_mtx_prod :: "(real^'m) \<Rightarrow> 'm sq_mtx \<Rightarrow> (real^'m)" is "(v*)" .

lift_definition sq_mtx_diag :: "(('m::finite) \<Rightarrow> real) \<Rightarrow> ('m::finite) sq_mtx" (binder "\<d>\<i>\<a>\<g> " 10)
  is diag_mat .

lift_definition sq_mtx_transpose :: "('m::finite) sq_mtx \<Rightarrow> 'm sq_mtx" ("_\<^sup>\<dagger>") is transpose .

lift_definition sq_mtx_inv :: "('m::finite) sq_mtx \<Rightarrow> 'm sq_mtx" ("_\<^sup>-\<^sup>1" [90]) is matrix_inv .

lift_definition sq_mtx_row :: "'m \<Rightarrow> ('m::finite) sq_mtx \<Rightarrow> real^'m" ("\<r>\<o>\<w>") is row .

lift_definition sq_mtx_col :: "'m \<Rightarrow> ('m::finite) sq_mtx \<Rightarrow> real^'m" ("\<c>\<o>\<l>")  is column .

lemma to_vec_eq_ith: "(to_vec A) $ i = A $$ i"
  by transfer simp

lemma to_mtx_ith[simp]:
  "(to_mtx A) $$ i1 = A $ i1"
  "(to_mtx A) $$ i1 $ i2 = A $ i1 $ i2"
  by (transfer, simp)+

lemma to_mtx_vec_lambda_ith[simp]: "to_mtx (\<chi> i j. x i j) $$ i1 $ i2 = x i1 i2"
  by (simp add: sq_mtx_ith_def)

lemma sq_mtx_eq_iff:
  shows "A = B = (\<forall>i j. A $$ i $ j = B $$ i $ j)"
    and "A = B = (\<forall>i. A $$ i = B $$ i)"
  by (transfer, simp add: vec_eq_iff)+

lemma sq_mtx_diag_simps[simp]:
  "i = j \<Longrightarrow> sq_mtx_diag f $$ i $ j = f i"
  "i \<noteq> j \<Longrightarrow> sq_mtx_diag f $$ i $ j = 0"
  "sq_mtx_diag f $$ i = axis i (f i)"
  unfolding sq_mtx_diag_def by (simp_all add: axis_def vec_eq_iff)

lemma sq_mtx_vec_mult_diag_axis: "(\<d>\<i>\<a>\<g> i. f i) *\<^sub>V (axis i k) = axis i (f i * k)"
  unfolding sq_mtx_diag_vec_mult axis_def by auto

lemma sq_mtx_vec_mult_eq: "m *\<^sub>V x = (\<chi> i. sum (\<lambda>j. (m $$ i $ j) * (x $ j)) UNIV)"
  by (transfer, simp add: matrix_vector_mult_def)

lemma sq_mtx_transpose_transpose[simp]: "(A\<^sup>\<dagger>)\<^sup>\<dagger> = A"
  by (transfer, simp)

lemma transpose_mult_vec_canon_row[simp]: "(A\<^sup>\<dagger>) *\<^sub>V (\<e> i) = \<r>\<o>\<w> i A"
  by transfer (simp add: row_def transpose_def axis_def matrix_vector_mult_def)

lemma row_ith[simp]: "\<r>\<o>\<w> i A = A $$ i"
  by transfer (simp add: row_def)

lemma mtx_vec_mult_canon: "A *\<^sub>V (\<e> i) = \<c>\<o>\<l> i A"
  by (transfer, simp add: matrix_vector_mult_basis)

subsection \<open> Ring of square matrices \<close>

instantiation sq_mtx :: (finite) ring
begin

lift_definition plus_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is "(+)" .

lift_definition zero_sq_mtx :: "'a sq_mtx" is "0" .

lift_definition uminus_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx" is "uminus" .

lift_definition minus_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is "(-)" .

lift_definition times_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is "(**)" .

declare plus_sq_mtx.rep_eq [simp]
    and minus_sq_mtx.rep_eq [simp]

instance apply intro_classes
  by(transfer, simp add: algebra_simps matrix_mul_assoc matrix_add_rdistrib matrix_add_ldistrib)+

end

lemma sq_mtx_zero_ith[simp]: "0 $$ i = 0"
  by (transfer, simp)

lemma sq_mtx_zero_nth[simp]: "0 $$ i $ j = 0"
  by transfer simp

lemma sq_mtx_plus_eq: "A + B = to_mtx (\<chi> i j. A$$i$j + B$$i$j)"
  by transfer (simp add: vec_eq_iff)

lemma sq_mtx_plus_ith[simp]:"(A + B) $$ i = A $$ i + B $$ i"
  unfolding sq_mtx_plus_eq by (simp add: vec_eq_iff)

lemma sq_mtx_minus_eq: "A - B = to_mtx (\<chi> i j. A$$i$j - B$$i$j)"
  by transfer (simp add: vec_eq_iff)

lemma sq_mtx_minus_ith[simp]:"(A - B) $$ i = A $$ i - B $$ i"
  unfolding sq_mtx_minus_eq by (simp add: vec_eq_iff)

lemma sq_mtx_times_eq: "A * B = to_mtx (\<chi> i j. sum (\<lambda>k. A$$i$k * B$$k$j) UNIV)"
  by transfer (simp add: matrix_matrix_mult_def)

lemma sq_mtx_plus_diag_diag[simp]: "sq_mtx_diag f + sq_mtx_diag g = (\<d>\<i>\<a>\<g> i. f i + g i)"
  by (subst sq_mtx_eq_iff) (simp add: axis_def)

lemma sq_mtx_minus_diag_diag[simp]: "sq_mtx_diag f - sq_mtx_diag g = (\<d>\<i>\<a>\<g> i. f i - g i)"
  by (subst sq_mtx_eq_iff) (simp add: axis_def)

lemma sum_sq_mtx_diag[simp]: "(\<Sum>n<m. sq_mtx_diag (g n)) = (\<d>\<i>\<a>\<g> i. \<Sum>n<m. (g n i))" for m::nat
  by (induct m, simp, subst sq_mtx_eq_iff, simp_all)

lemma sq_mtx_mult_diag_diag[simp]: "sq_mtx_diag f * sq_mtx_diag g = (\<d>\<i>\<a>\<g> i. f i * g i)"
  by (simp add: matrix_mul_diag_diag sq_mtx_diag.abs_eq times_sq_mtx.abs_eq)

lemma sq_mtx_mult_diagl: "(\<d>\<i>\<a>\<g> i. f i) * A = to_mtx (\<chi> i j. f i * A $$ i $ j)"
  by transfer (simp add: matrix_mul_diag_matl)

lemma sq_mtx_mult_diagr: "A * (\<d>\<i>\<a>\<g> i. f i) = to_mtx (\<chi> i j. A $$ i $ j * f j)"
  by transfer (simp add: matrix_matrix_mul_diag_matr)

lemma mtx_vec_mult_0l[simp]: "0 *\<^sub>V x = 0"
  by (simp add: sq_mtx_vec_mult.abs_eq zero_sq_mtx_def)

lemma mtx_vec_mult_0r[simp]: "A *\<^sub>V 0 = 0"
  by (transfer, simp)

lemma mtx_vec_mult_add_rdistr: "(A + B) *\<^sub>V x = A *\<^sub>V x + B *\<^sub>V x"
  unfolding plus_sq_mtx_def
  apply(transfer)
  by (simp add: matrix_vector_mult_add_rdistrib)

lemma mtx_vec_mult_add_rdistl: "A *\<^sub>V (x + y) = A *\<^sub>V x + A *\<^sub>V y"
  unfolding plus_sq_mtx_def
  apply transfer
  by (simp add: matrix_vector_right_distrib)

lemma mtx_vec_mult_minus_rdistrib: "(A - B) *\<^sub>V x = A *\<^sub>V x - B *\<^sub>V x"
  unfolding minus_sq_mtx_def by(transfer, simp add: matrix_vector_mult_diff_rdistrib)

lemma mtx_vec_mult_minus_ldistrib: "A *\<^sub>V (x - y) =  A *\<^sub>V x -  A *\<^sub>V y"
  by (metis (no_types, lifting) add_diff_cancel diff_add_cancel
      matrix_vector_right_distrib sq_mtx_vec_mult.rep_eq)

lemma sq_mtx_times_vec_assoc: "(A * B) *\<^sub>V x = A *\<^sub>V (B *\<^sub>V x)"
  by (transfer, simp add: matrix_vector_mul_assoc)

lemma sq_mtx_vec_mult_sum_cols: "A *\<^sub>V x = sum (\<lambda>i. x $ i *\<^sub>R \<c>\<o>\<l> i A) UNIV"
  by(transfer) (simp add: matrix_mult_sum scalar_mult_eq_scaleR)

subsection \<open> Real normed vector space of square matrices \<close>

instantiation sq_mtx :: (finite) real_normed_vector
begin

definition norm_sq_mtx :: "'a sq_mtx \<Rightarrow> real" where "\<parallel>A\<parallel> = \<parallel>to_vec A\<parallel>\<^sub>o\<^sub>p"

lift_definition scaleR_sq_mtx :: "real \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is scaleR .

definition sgn_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx"
  where "sgn_sq_mtx A = (inverse (\<parallel>A\<parallel>)) *\<^sub>R A"

definition dist_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> real"
  where "dist_sq_mtx A B = \<parallel>A - B\<parallel>"

definition uniformity_sq_mtx :: "('a sq_mtx \<times> 'a sq_mtx) filter"
  where "uniformity_sq_mtx = (INF e\<in>{0<..}. principal {(x, y). dist x y < e})"

definition open_sq_mtx :: "'a sq_mtx set \<Rightarrow> bool"
  where "open_sq_mtx U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> U)"

instance apply intro_classes
  unfolding sgn_sq_mtx_def open_sq_mtx_def dist_sq_mtx_def uniformity_sq_mtx_def
            prefer 10
            apply(transfer, simp add: norm_sq_mtx_def op_norm_triangle)
           prefer 9
           apply(simp_all add: norm_sq_mtx_def zero_sq_mtx_def op_norm_eq_0)
  by (transfer, simp add: norm_sq_mtx_def op_norm_scaleR algebra_simps)+

end

lemma sq_mtx_scaleR_eq: "c *\<^sub>R A = to_mtx (\<chi> i j. c *\<^sub>R A $$ i $ j)"
  by transfer (simp add: vec_eq_iff)

lemma scaleR_to_mtx_ith[simp]: "c *\<^sub>R (to_mtx A) $$ i1 $ i2 = c * A $ i1 $ i2"
  by transfer (simp add: scaleR_vec_def)

lemma sq_mtx_scaleR_ith[simp]: "(c *\<^sub>R A) $$ i = (c  *\<^sub>R (A $$ i))"
  by (unfold scaleR_sq_mtx_def, transfer, simp)

lemma scaleR_sq_mtx_diag: "c *\<^sub>R sq_mtx_diag f = (\<d>\<i>\<a>\<g> i. c * f i)"
  by (subst sq_mtx_eq_iff, simp add: axis_def)

lemma scaleR_mtx_vec_assoc: "(c *\<^sub>R A) *\<^sub>V x = c *\<^sub>R (A *\<^sub>V x)"
  unfolding scaleR_sq_mtx_def sq_mtx_vec_mult_def apply simp
  by (simp add: scaleR_matrix_vector_assoc)

lemma mtx_vec_scaleR_commute: "A *\<^sub>V (c *\<^sub>R x) = c *\<^sub>R (A *\<^sub>V x)"
  unfolding scaleR_sq_mtx_def sq_mtx_vec_mult_def apply(simp, transfer)
  by (simp add: vector_scaleR_commute)

lemma mtx_times_scaleR_commute: "A * (c *\<^sub>R B) = c *\<^sub>R (A * B)" for A::"('n::finite) sq_mtx"
  unfolding sq_mtx_scaleR_eq sq_mtx_times_eq
  apply(simp add: to_mtx_inject)
  apply(simp add: vec_eq_iff fun_eq_iff)
  by (simp add: semiring_normalization_rules(19) vector_space_over_itself.scale_sum_right)

lemma le_mtx_norm: "m \<in> {\<parallel>A *\<^sub>V x\<parallel> |x. \<parallel>x\<parallel> = 1} \<Longrightarrow> m \<le> \<parallel>A\<parallel>"
  using cSup_upper[of _ "{\<parallel>(to_vec A) *v x\<parallel> | x. \<parallel>x\<parallel> = 1}"]
  by (simp add: op_norm_set_proptys(2) op_norm_def norm_sq_mtx_def sq_mtx_vec_mult.rep_eq)

lemma norm_vec_mult_le: "\<parallel>A *\<^sub>V x\<parallel> \<le> (\<parallel>A\<parallel>) * (\<parallel>x\<parallel>)"
  by (simp add: norm_matrix_le_mult_op_norm norm_sq_mtx_def sq_mtx_vec_mult.rep_eq)

lemma bounded_bilinear_sq_mtx_vec_mult: "bounded_bilinear (\<lambda>A s. A *\<^sub>V s)"
  apply (rule bounded_bilinear.intro, simp_all add: mtx_vec_mult_add_rdistr
      mtx_vec_mult_add_rdistl scaleR_mtx_vec_assoc mtx_vec_scaleR_commute)
  by (rule_tac x=1 in exI, auto intro!: norm_vec_mult_le)

lemma norm_sq_mtx_def2: "\<parallel>A\<parallel> = Sup {\<parallel>A *\<^sub>V x\<parallel> |x. \<parallel>x\<parallel> = 1}"
  unfolding norm_sq_mtx_def op_norm_def sq_mtx_vec_mult_def by simp

lemma norm_sq_mtx_def3: "\<parallel>A\<parallel> = (SUP x. (\<parallel>A *\<^sub>V x\<parallel>) / (\<parallel>x\<parallel>))"
  unfolding norm_sq_mtx_def onorm_def sq_mtx_vec_mult_def by simp

lemma norm_sq_mtx_diag: "\<parallel>sq_mtx_diag f\<parallel> = Max {\<bar>f i\<bar> |i. i \<in> UNIV}"
  unfolding norm_sq_mtx_def apply transfer
  by (rule op_norm_diag_mat_eq)

lemma sq_mtx_norm_le_sum_col: "\<parallel>A\<parallel> \<le> (\<Sum>i\<in>UNIV. \<parallel>\<c>\<o>\<l> i A\<parallel>)"
  using op_norm_le_sum_column[of "to_vec A"]
  apply(simp add: norm_sq_mtx_def)
  by(transfer, simp add: op_norm_le_sum_column)

lemma norm_le_transpose: "\<parallel>A\<parallel> \<le> \<parallel>A\<^sup>\<dagger>\<parallel>"
  unfolding norm_sq_mtx_def by transfer (rule op_norm_le_transpose)

lemma norm_eq_norm_transpose[simp]: "\<parallel>A\<^sup>\<dagger>\<parallel> = \<parallel>A\<parallel>"
  using norm_le_transpose[of A] and norm_le_transpose[of "A\<^sup>\<dagger>"] by simp

lemma norm_column_le_norm: "\<parallel>A $$ i\<parallel> \<le> \<parallel>A\<parallel>"
  using norm_vec_mult_le[of "A\<^sup>\<dagger>" "\<e> i"] by simp

subsection \<open> Real normed algebra of square matrices \<close>

instantiation sq_mtx :: (finite) real_normed_algebra_1
begin

lift_definition one_sq_mtx :: "'a sq_mtx" is "to_mtx (mat 1)" .

lemma sq_mtx_one_idty: "1 * A = A" "A * 1 = A" for A :: "'a sq_mtx"
  by(transfer, transfer, unfold mat_def matrix_matrix_mult_def, simp add: vec_eq_iff)+

lemma sq_mtx_norm_1: "\<parallel>(1::'a sq_mtx)\<parallel> = 1"
  unfolding one_sq_mtx_def norm_sq_mtx_def
  apply(simp add: op_norm_def)
  apply(subst cSup_eq[of _ 1])
  using ex_norm_eq_1 by auto

lemma sq_mtx_norm_times: "\<parallel>A * B\<parallel> \<le> (\<parallel>A\<parallel>) * (\<parallel>B\<parallel>)" for A :: "'a sq_mtx"
  unfolding norm_sq_mtx_def times_sq_mtx_def by(simp add: op_norm_matrix_matrix_mult_le)

instance
  apply intro_classes
  apply(simp_all add: sq_mtx_one_idty sq_mtx_norm_1 sq_mtx_norm_times)
  apply(simp_all add: to_mtx_inject vec_eq_iff one_sq_mtx_def zero_sq_mtx_def mat_def)
  by(transfer, simp add: scalar_matrix_assoc matrix_scalar_ac)+

end

lemma sq_mtx_one_ith_simps[simp]: "1 $$ i $ i = 1" "i \<noteq> j \<Longrightarrow> 1 $$ i $ j = 0"
  unfolding one_sq_mtx_def mat_def by simp_all

lemma of_nat_eq_sq_mtx_diag[simp]: "of_nat m = (\<d>\<i>\<a>\<g> i. m)"
  by (induct m) (simp, subst sq_mtx_eq_iff, simp add: axis_def)+

lemma mtx_vec_mult_1[simp]: "1 *\<^sub>V s = s"
  by (auto simp: sq_mtx_vec_mult_def one_sq_mtx_def
      mat_def vec_eq_iff matrix_vector_mult_def)

lemma sq_mtx_diag_one[simp]: "(\<d>\<i>\<a>\<g> i. 1) = 1"
  by (subst sq_mtx_eq_iff, simp add: one_sq_mtx_def mat_def axis_def)

abbreviation "mtx_invertible A \<equiv> invertible (to_vec A)"

lemma mtx_invertible_def: "mtx_invertible A \<longleftrightarrow> (\<exists>A'. A' * A = 1 \<and> A * A' = 1)"
  apply (unfold sq_mtx_inv_def times_sq_mtx_def one_sq_mtx_def invertible_def, clarsimp, safe)
   apply(rule_tac x="to_mtx A'" in exI, simp)
  by (rule_tac x="to_vec A'" in exI, simp add: to_mtx_inject)

lemma mtx_invertibleD[simp]:
  assumes "mtx_invertible A"
  shows "A\<^sup>-\<^sup>1 * A = 1" and "A * A\<^sup>-\<^sup>1 = 1"
  apply (unfold sq_mtx_inv_def times_sq_mtx_def one_sq_mtx_def)
  using assms by simp_all

lemma mtx_invertible_inv[simp]: "mtx_invertible A \<Longrightarrow> mtx_invertible (A\<^sup>-\<^sup>1)"
  using mtx_invertibleD mtx_invertibleI by blast

lemma mtx_invertible_one[simp]: "mtx_invertible 1"
  by (simp add: one_sq_mtx.rep_eq)

lemma sq_mtx_inv_unique:
  assumes "A * B = 1" and "B * A = 1"
  shows "A\<^sup>-\<^sup>1 = B"
  by (metis (no_types, lifting) assms mtx_invertibleD(2)
      mtx_invertibleI mult.assoc sq_mtx_one_idty(1))

lemma sq_mtx_inv_idempotent[simp]: "mtx_invertible A \<Longrightarrow> A\<^sup>-\<^sup>1\<^sup>-\<^sup>1 = A"
  using mtx_invertibleD sq_mtx_inv_unique by blast

lemma sq_mtx_inv_mult:
  assumes "mtx_invertible A" and "mtx_invertible B"
  shows "(A * B)\<^sup>-\<^sup>1 = B\<^sup>-\<^sup>1 * A\<^sup>-\<^sup>1"
  by (simp add: assms matrix_inv_matrix_mul sq_mtx_inv_def times_sq_mtx_def)

lemma sq_mtx_inv_one[simp]: "1\<^sup>-\<^sup>1 = 1"
  by (simp add: sq_mtx_inv_unique)

definition similar_sq_mtx :: "('n::finite) sq_mtx \<Rightarrow> 'n sq_mtx \<Rightarrow> bool" (infixr "\<sim>" 25)
  where "(A \<sim> B) \<longleftrightarrow> (\<exists> P. mtx_invertible P \<and> A = P\<^sup>-\<^sup>1 * B * P)"

lemma similar_sq_mtx_matrix: "(A \<sim> B) = similar_matrix (to_vec A) (to_vec B)"
  apply(unfold similar_matrix_def similar_sq_mtx_def, safe)
   apply (metis sq_mtx_inv.rep_eq times_sq_mtx.rep_eq)
  by (metis UNIV_I sq_mtx_inv.abs_eq times_sq_mtx.abs_eq to_mtx_inverse to_vec_inverse)

lemma similar_sq_mtx_refl[simp]: "A \<sim> A"
  by (unfold similar_sq_mtx_def, rule_tac x="1" in exI, simp)

lemma similar_sq_mtx_simm: "A \<sim> B \<Longrightarrow> B \<sim> A"
  apply(unfold similar_sq_mtx_def, clarsimp)
  apply(rule_tac x="P\<^sup>-\<^sup>1" in exI, simp add: mult.assoc)
  by (metis mtx_invertibleD(2) mult.assoc mult.left_neutral)

lemma similar_sq_mtx_trans: "A \<sim> B \<Longrightarrow> B \<sim> C \<Longrightarrow> A \<sim> C"
  unfolding similar_sq_mtx_matrix using similar_matrix_trans by blast

lemma power_similiar_sq_mtx_diag_eq:
  assumes "mtx_invertible P"
      and "A = P\<^sup>-\<^sup>1 * (sq_mtx_diag f) * P"
    shows "A^n = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i^n) * P"
proof(induct n, simp_all add: assms)
  fix n::nat
  have "P\<^sup>-\<^sup>1 * sq_mtx_diag f * P * (P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P) =
  P\<^sup>-\<^sup>1 * sq_mtx_diag f * (\<d>\<i>\<a>\<g> i. f i ^ n) * P"
    by (metis (no_types, lifting) assms(1) mtx_invertibleD(2) mult.assoc mult.right_neutral)
  also have "... = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i * f i ^ n) * P"
    by (simp add: mult.assoc)
  finally show "P\<^sup>-\<^sup>1 * sq_mtx_diag f * P * (P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P) =
  P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i * f i ^ n) * P" .
qed

lemma power_similar_sq_mtx_diag:
  assumes "A \<sim> (sq_mtx_diag f)"
  shows "A^n \<sim> (\<d>\<i>\<a>\<g> i. f i^n)"
  using assms power_similiar_sq_mtx_diag_eq
  unfolding similar_sq_mtx_def by blast

subsection \<open> Banach space of square matrices \<close>

lemma Cauchy_cols:
  fixes X :: "nat \<Rightarrow> ('a::finite) sq_mtx"
  assumes "Cauchy X"
  shows "Cauchy (\<lambda>n. \<c>\<o>\<l> i (X n))"
proof(unfold Cauchy_def dist_norm, clarsimp)
  fix \<epsilon>::real assume "\<epsilon> > 0"
  then obtain M where M_def:"\<forall>m\<ge>M. \<forall>n\<ge>M. \<parallel>X m - X n\<parallel> < \<epsilon>"
    using \<open>Cauchy X\<close> unfolding Cauchy_def by(simp add: dist_sq_mtx_def) metis
  {fix m n assume "m \<ge> M" and "n \<ge> M"
    hence "\<epsilon> > \<parallel>X m - X n\<parallel>"
      using M_def by blast
    moreover have "\<parallel>X m - X n\<parallel> \<ge> \<parallel>(X m - X n) *\<^sub>V \<e> i\<parallel>"
      by(rule le_mtx_norm[of _ "X m - X n"], force)
    moreover have "\<parallel>(X m - X n) *\<^sub>V \<e> i\<parallel> = \<parallel>X m *\<^sub>V \<e> i - X n *\<^sub>V \<e> i\<parallel>"
      by (simp add: mtx_vec_mult_minus_rdistrib)
    moreover have "... = \<parallel>\<c>\<o>\<l> i (X m) - \<c>\<o>\<l> i (X n)\<parallel>"
      by (simp add: mtx_vec_mult_minus_rdistrib mtx_vec_mult_canon)
    ultimately have "\<parallel>\<c>\<o>\<l> i (X m) - \<c>\<o>\<l> i (X n)\<parallel> < \<epsilon>"
      by linarith}
  thus "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. \<parallel>\<c>\<o>\<l> i (X m) - \<c>\<o>\<l> i (X n)\<parallel> < \<epsilon>"
    by blast
qed

lemma col_convergence:
  assumes "\<forall>i. (\<lambda>n. \<c>\<o>\<l> i (X n)) \<longlonglongrightarrow> L $ i"
  shows "X \<longlonglongrightarrow> to_mtx (transpose L)"
proof(unfold LIMSEQ_def dist_norm, clarsimp)
  let ?L = "to_mtx (transpose L)"
  let ?a = "CARD('a)" fix \<epsilon>::real assume "\<epsilon> > 0"
  hence "\<epsilon> / ?a > 0" by simp
  hence "\<forall>i. \<exists> N. \<forall>n\<ge>N. \<parallel>\<c>\<o>\<l> i (X n) - L $ i\<parallel> < \<epsilon>/?a"
    using assms unfolding LIMSEQ_def dist_norm convergent_def by blast
  then obtain N where "\<forall>i. \<forall>n\<ge>N. \<parallel>\<c>\<o>\<l> i (X n) - L $ i\<parallel> < \<epsilon>/?a"
    using finite_nat_minimal_witness[of "\<lambda> i n. \<parallel>\<c>\<o>\<l> i (X n) - L $ i\<parallel> < \<epsilon>/?a"] by blast
  also have "\<And>i n. (\<c>\<o>\<l> i (X n) - L $ i) = (\<c>\<o>\<l> i (X n - ?L))"
    unfolding minus_sq_mtx_def by(transfer, simp add: transpose_def vec_eq_iff column_def)
  ultimately have N_def:"\<forall>i. \<forall>n\<ge>N. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel> < \<epsilon>/?a"
    by auto
  have "\<forall>n\<ge>N. \<parallel>X n - ?L\<parallel> < \<epsilon>"
  proof(rule allI, rule impI)
    fix n::nat assume "N \<le> n"
    hence "\<forall> i. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel> < \<epsilon>/?a"
      using N_def by blast
    hence "(\<Sum>i\<in>UNIV. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel>) < (\<Sum>(i::'a)\<in>UNIV. \<epsilon>/?a)"
      using sum_strict_mono[of _ "\<lambda>i. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel>"] by force
    moreover have "\<parallel>X n - ?L\<parallel> \<le> (\<Sum>i\<in>UNIV. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel>)"
      using sq_mtx_norm_le_sum_col by blast
    moreover have "(\<Sum>(i::'a)\<in>UNIV. \<epsilon>/?a) = \<epsilon>"
      by force
    ultimately show "\<parallel>X n - ?L\<parallel> < \<epsilon>"
      by linarith
  qed
  thus "\<exists>no. \<forall>n\<ge>no. \<parallel>X n - ?L\<parallel> < \<epsilon>"
    by blast
qed

instance sq_mtx :: (finite) banach
proof(standard)
  fix X :: "nat \<Rightarrow> 'a sq_mtx"
  assume "Cauchy X"
  hence "\<And>i. Cauchy (\<lambda>n. \<c>\<o>\<l> i (X n))"
    using Cauchy_cols by blast
  hence obs: "\<forall>i. \<exists>! L. (\<lambda>n. \<c>\<o>\<l> i (X n)) \<longlonglongrightarrow> L"
    using Cauchy_convergent convergent_def LIMSEQ_unique by fastforce
  define L where "L = (\<chi> i. lim (\<lambda>n. \<c>\<o>\<l> i (X n)))"
  hence "\<forall>i. (\<lambda>n. \<c>\<o>\<l> i (X n)) \<longlonglongrightarrow> L $ i"
    using obs theI_unique[of "\<lambda>L. (\<lambda>n. \<c>\<o>\<l> _ (X n)) \<longlonglongrightarrow> L" "L $ _"] by (simp add: lim_def)
  thus "convergent X"
    using col_convergence unfolding convergent_def by blast
qed

lemma exp_similiar_sq_mtx_diag_eq:
  assumes "mtx_invertible P"
      and "A = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i) * P"
    shows "exp A = P\<^sup>-\<^sup>1 * exp (\<d>\<i>\<a>\<g> i. f i) * P"
proof(unfold exp_def power_similiar_sq_mtx_diag_eq[OF assms])
  have "(\<Sum>n. P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P /\<^sub>R fact n) =
  (\<Sum>n. P\<^sup>-\<^sup>1 * ((\<d>\<i>\<a>\<g> i. f i ^ n) /\<^sub>R fact n) * P)"
    by simp
  also have "... = (\<Sum>n. P\<^sup>-\<^sup>1 * ((\<d>\<i>\<a>\<g> i. f i ^ n) /\<^sub>R fact n)) * P"
    apply(subst suminf_multr[OF bounded_linear.summable[OF bounded_linear_mult_right]])
    unfolding power_sq_mtx_diag[symmetric] by (simp_all add: summable_exp_generic)
  also have "... = P\<^sup>-\<^sup>1 * (\<Sum>n. (\<d>\<i>\<a>\<g> i. f i ^ n) /\<^sub>R fact n) * P"
    apply(subst suminf_mult[of _ "P\<^sup>-\<^sup>1"])
    unfolding power_sq_mtx_diag[symmetric]
    by (simp_all add: summable_exp_generic)
  finally show "(\<Sum>n. P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P /\<^sub>R fact n) =
  P\<^sup>-\<^sup>1 * (\<Sum>n. sq_mtx_diag f ^ n /\<^sub>R fact n) * P"
    unfolding power_sq_mtx_diag by simp
qed

lemma exp_similiar_sq_mtx_diag:
  assumes "A \<sim> sq_mtx_diag f"
  shows "exp A \<sim> exp (sq_mtx_diag f)"
  using assms exp_similiar_sq_mtx_diag_eq
  unfolding similar_sq_mtx_def by blast

lemma suminf_sq_mtx_diag:
  assumes "\<forall>i. (\<lambda>n. f n i) sums (suminf (\<lambda>n. f n i))"
  shows "(\<Sum>n. (\<d>\<i>\<a>\<g> i. f n i)) = (\<d>\<i>\<a>\<g> i. \<Sum>n. f n i)"
proof(rule suminfI, unfold sums_def LIMSEQ_iff, clarsimp simp: norm_sq_mtx_diag)
  let ?g = "\<lambda>n i. \<bar>(\<Sum>n<n. f n i) - (\<Sum>n. f n i)\<bar>"
  fix r::real assume "r > 0"
  have "\<forall>i. \<exists>no. \<forall>n\<ge>no. ?g n i < r"
    using assms \<open>r > 0\<close> unfolding sums_def LIMSEQ_iff by clarsimp
  then obtain N where key: "\<forall>i. \<forall>n\<ge>N. ?g n i < r"
    using finite_nat_minimal_witness[of "\<lambda>i n. ?g n i < r"] by blast
  {fix n::nat
    assume "n \<ge> N"
    obtain i where i_def: "Max {x. \<exists>i. x = ?g n i} = ?g n i"
      using cMax_finite_ex[of "{x. \<exists>i. x = ?g n i}"] by auto
    hence "?g n i < r"
      using key \<open>n \<ge> N\<close> by blast
    hence "Max {x. \<exists>i. x = ?g n i} < r"
      unfolding i_def[symmetric] .}
  thus "\<exists>N. \<forall>n\<ge>N. Max {x. \<exists>i. x = ?g n i} < r"
    by blast
qed

lemma exp_sq_mtx_diag: "exp (sq_mtx_diag f) = (\<d>\<i>\<a>\<g> i. exp (f i))"
  apply(unfold exp_def, simp add: power_sq_mtx_diag scaleR_sq_mtx_diag)
  apply(rule suminf_sq_mtx_diag)
  using exp_converges[of "f _"]
  unfolding sums_def LIMSEQ_iff exp_def by force

lemma exp_scaleR_diagonal1:
  assumes "mtx_invertible P" and "A = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i) * P"
    shows "exp (t *\<^sub>R A) = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P"
proof-
  have "exp (t *\<^sub>R A) = exp (P\<^sup>-\<^sup>1 * (t *\<^sub>R sq_mtx_diag f) * P)"
    using assms by simp
  also have "... = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P"
    by (metis assms(1) exp_similiar_sq_mtx_diag_eq exp_sq_mtx_diag scaleR_sq_mtx_diag)
  finally show "exp (t *\<^sub>R A) = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P" .
qed

lemma exp_scaleR_diagonal2:
  assumes "mtx_invertible P" and "A = P * (\<d>\<i>\<a>\<g> i. f i) * P\<^sup>-\<^sup>1"
    shows "exp (t *\<^sub>R A) = P * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P\<^sup>-\<^sup>1"
  apply(subst sq_mtx_inv_idempotent[OF assms(1), symmetric])
  apply(rule exp_scaleR_diagonal1)
  by (simp_all add: assms)

subsection \<open> Examples \<close>

definition "mtx A = to_mtx (vector (map vector A))"

lemma vector_nth_eq: "(vector A) $ i = foldr (\<lambda>x f n. (f (n + 1))(n := x)) A (\<lambda>n x. 0) 1 i"
  unfolding vector_def by simp

lemma mtx_ith_eq[simp]: "mtx A $$ i $ j = foldr (\<lambda>x f n. (f (n + 1))(n := x))
  (map (\<lambda>l. vec_lambda (foldr (\<lambda>x f n. (f (n + 1))(n := x)) l (\<lambda>n x. 0) 1)) A) (\<lambda>n x. 0) 1 i $ j"
  unfolding mtx_def vector_def by (simp add: vector_nth_eq)

subsubsection \<open> 2x2 matrices \<close>

lemma mtx2_eq_iff: "(mtx
  ([a1, b1] #
   [c1, d1] # []) :: 2 sq_mtx) = mtx
  ([a2, b2] #
   [c2, d2] # []) \<longleftrightarrow> a1 = a2 \<and> b1 = b2 \<and> c1 = c2 \<and> d1 = d2"
  apply(simp add: sq_mtx_eq_iff, safe)
  using exhaust_2 by force+

lemma mtx2_to_mtx: "mtx
  ([a, b] #
   [c, d] # []) =
  to_mtx (\<chi> i j::2. if i=1 \<and> j=1 then a
  else (if i=1 \<and> j=2 then b
  else (if i=2 \<and> j=1 then c
  else d)))"
  apply(subst sq_mtx_eq_iff)
  using exhaust_2 by force

abbreviation diag2 :: "real \<Rightarrow> real \<Rightarrow> 2 sq_mtx"
  where "diag2 \<iota>\<^sub>1 \<iota>\<^sub>2 \<equiv> mtx
   ([\<iota>\<^sub>1, 0] #
    [0, \<iota>\<^sub>2] # [])"

lemma diag2_eq: "diag2 (\<iota> 1) (\<iota> 2) = (\<d>\<i>\<a>\<g> i. \<iota> i)"
  apply(simp add: sq_mtx_eq_iff)
  using exhaust_2 by (force simp: axis_def)

lemma one_mtx2: "(1::2 sq_mtx) = diag2 1 1"
  apply(subst sq_mtx_eq_iff)
  using exhaust_2 by force

lemma zero_mtx2: "(0::2 sq_mtx) = diag2 0 0"
  by (simp add: sq_mtx_eq_iff)

lemma scaleR_mtx2: "k *\<^sub>R mtx
  ([a, b] #
   [c, d] # []) = mtx
  ([k*a, k*b] #
   [k*c, k*d] # [])"
  by (simp add: sq_mtx_eq_iff)

lemma uminus_mtx2: "-mtx
  ([a, b] #
   [c, d] # []) = (mtx
  ([-a, -b] #
   [-c, -d] # [])::2 sq_mtx)"
  by (simp add: sq_mtx_uminus_eq sq_mtx_eq_iff)

lemma plus_mtx2: "mtx
  ([a1, b1] #
   [c1, d1] # []) + mtx
  ([a2, b2] #
   [c2, d2] # []) = ((mtx
  ([a1+a2, b1+b2] #
   [c1+c2, d1+d2] # []))::2 sq_mtx)"
  by (simp add: sq_mtx_eq_iff)

lemma minus_mtx2: "mtx
  ([a1, b1] #
   [c1, d1] # []) - mtx
  ([a2, b2] #
   [c2, d2] # []) = ((mtx
  ([a1-a2, b1-b2] #
   [c1-c2, d1-d2] # []))::2 sq_mtx)"
  by (simp add: sq_mtx_eq_iff)

lemma times_mtx2: "mtx
  ([a1, b1] #
   [c1, d1] # []) * mtx
  ([a2, b2] #
   [c2, d2] # []) = ((mtx
  ([a1*a2+b1*c2, a1*b2+b1*d2] #
   [c1*a2+d1*c2, c1*b2+d1*d2] # []))::2 sq_mtx)"
  unfolding sq_mtx_times_eq UNIV_2
  by (simp add: sq_mtx_eq_iff)

subsubsection \<open> 3x3 matrices \<close>

lemma mtx3_to_mtx: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) =
  to_mtx (\<chi> i j::3. if i=1 \<and> j=1 then a\<^sub>1\<^sub>1
  else (if i=1 \<and> j=2 then a\<^sub>1\<^sub>2
  else (if i=1 \<and> j=3 then a\<^sub>1\<^sub>3
  else (if i=2 \<and> j=1 then a\<^sub>2\<^sub>1
  else (if i=2 \<and> j=2 then a\<^sub>2\<^sub>2
  else (if i=2 \<and> j=3 then a\<^sub>2\<^sub>3
  else (if i=3 \<and> j=1 then a\<^sub>3\<^sub>1
  else (if i=3 \<and> j=2 then a\<^sub>3\<^sub>2
  else a\<^sub>3\<^sub>3))))))))"
  apply(simp add: sq_mtx_eq_iff)
  using exhaust_3 by force

abbreviation diag3 :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 3 sq_mtx"
  where "diag3 \<iota>\<^sub>1 \<iota>\<^sub>2 \<iota>\<^sub>3 \<equiv> mtx
  ([\<iota>\<^sub>1, 0, 0] #
   [0, \<iota>\<^sub>2, 0] #
   [0, 0, \<iota>\<^sub>3] # [])"

lemma diag3_eq: "diag3 (\<iota> 1) (\<iota> 2) (\<iota> 3) = (\<d>\<i>\<a>\<g> i. \<iota> i)"
  apply(simp add: sq_mtx_eq_iff)
  using exhaust_3 by (force simp: axis_def)

lemma one_mtx3: "(1::3 sq_mtx) = diag3 1 1 1"
  apply(subst sq_mtx_eq_iff)
  using exhaust_3 by force

lemma zero_mtx3: "(0::3 sq_mtx) = diag3 0 0 0"
  by (simp add: sq_mtx_eq_iff)

lemma scaleR_mtx3: "k *\<^sub>R mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) = mtx
  ([k*a\<^sub>1\<^sub>1, k*a\<^sub>1\<^sub>2, k*a\<^sub>1\<^sub>3] #
   [k*a\<^sub>2\<^sub>1, k*a\<^sub>2\<^sub>2, k*a\<^sub>2\<^sub>3] #
   [k*a\<^sub>3\<^sub>1, k*a\<^sub>3\<^sub>2, k*a\<^sub>3\<^sub>3] # [])"
  by (simp add: sq_mtx_eq_iff)

lemma plus_mtx3: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) + mtx
  ([b\<^sub>1\<^sub>1, b\<^sub>1\<^sub>2, b\<^sub>1\<^sub>3] #
   [b\<^sub>2\<^sub>1, b\<^sub>2\<^sub>2, b\<^sub>2\<^sub>3] #
   [b\<^sub>3\<^sub>1, b\<^sub>3\<^sub>2, b\<^sub>3\<^sub>3] # []) = (mtx
  ([a\<^sub>1\<^sub>1+b\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2+b\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3+b\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1+b\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2+b\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3+b\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1+b\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2+b\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3+b\<^sub>3\<^sub>3] # [])::3 sq_mtx)"
  by (subst sq_mtx_eq_iff) simp

lemma minus_mtx3: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) - mtx
  ([b\<^sub>1\<^sub>1, b\<^sub>1\<^sub>2, b\<^sub>1\<^sub>3] #
   [b\<^sub>2\<^sub>1, b\<^sub>2\<^sub>2, b\<^sub>2\<^sub>3] #
   [b\<^sub>3\<^sub>1, b\<^sub>3\<^sub>2, b\<^sub>3\<^sub>3] # []) = (mtx
  ([a\<^sub>1\<^sub>1-b\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2-b\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3-b\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1-b\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2-b\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3-b\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1-b\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2-b\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3-b\<^sub>3\<^sub>3] # [])::3 sq_mtx)"
  by (simp add: sq_mtx_eq_iff)

lemma times_mtx3: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) * mtx
  ([b\<^sub>1\<^sub>1, b\<^sub>1\<^sub>2, b\<^sub>1\<^sub>3] #
   [b\<^sub>2\<^sub>1, b\<^sub>2\<^sub>2, b\<^sub>2\<^sub>3] #
   [b\<^sub>3\<^sub>1, b\<^sub>3\<^sub>2, b\<^sub>3\<^sub>3] # []) = (mtx
  ([a\<^sub>1\<^sub>1*b\<^sub>1\<^sub>1+a\<^sub>1\<^sub>2*b\<^sub>2\<^sub>1+a\<^sub>1\<^sub>3*b\<^sub>3\<^sub>1, a\<^sub>1\<^sub>1*b\<^sub>1\<^sub>2+a\<^sub>1\<^sub>2*b\<^sub>2\<^sub>2+a\<^sub>1\<^sub>3*b\<^sub>3\<^sub>2, a\<^sub>1\<^sub>1*b\<^sub>1\<^sub>3+a\<^sub>1\<^sub>2*b\<^sub>2\<^sub>3+a\<^sub>1\<^sub>3*b\<^sub>3\<^sub>3] #
   [a\<^sub>2\<^sub>1*b\<^sub>1\<^sub>1+a\<^sub>2\<^sub>2*b\<^sub>2\<^sub>1+a\<^sub>2\<^sub>3*b\<^sub>3\<^sub>1, a\<^sub>2\<^sub>1*b\<^sub>1\<^sub>2+a\<^sub>2\<^sub>2*b\<^sub>2\<^sub>2+a\<^sub>2\<^sub>3*b\<^sub>3\<^sub>2, a\<^sub>2\<^sub>1*b\<^sub>1\<^sub>3+a\<^sub>2\<^sub>2*b\<^sub>2\<^sub>3+a\<^sub>2\<^sub>3*b\<^sub>3\<^sub>3] #
   [a\<^sub>3\<^sub>1*b\<^sub>1\<^sub>1+a\<^sub>3\<^sub>2*b\<^sub>2\<^sub>1+a\<^sub>3\<^sub>3*b\<^sub>3\<^sub>1, a\<^sub>3\<^sub>1*b\<^sub>1\<^sub>2+a\<^sub>3\<^sub>2*b\<^sub>2\<^sub>2+a\<^sub>3\<^sub>3*b\<^sub>3\<^sub>2, a\<^sub>3\<^sub>1*b\<^sub>1\<^sub>3+a\<^sub>3\<^sub>2*b\<^sub>2\<^sub>3+a\<^sub>3\<^sub>3*b\<^sub>3\<^sub>3] # [])::3 sq_mtx)"
  unfolding sq_mtx_times_eq
  unfolding UNIV_3 by (simp add: sq_mtx_eq_iff)

end