(*<*)
(* Author: Dmitriy Traytel *)

header {* A Codatatype of Formal Languages *}

theory Coinductive_Language
imports Main
begin

hide_const (open) Inter
(*>*)

section {* Introduction *}

text {*
We define formal languages as a codataype of infinite trees branching over the
alphabet @{typ 'a}. Each node in such a tree indicates whether the path to this
node constitutes a word inside or outside of the language.

*}

codatatype 'a language = Lang (\<oo>: bool) (\<dd>: "'a \<Rightarrow> 'a language")

text {*
This codatatype is isormorphic to the set of lists representation of languages,
but caters for definitions by corecursion and proofs by coinduction.

Regular operations on languages are then defined by primitive corecursion.
A difficulty arises here, since the standard definitions of concatenation and
iteration from the coalgebraic literature are not primitively corecursive---they
require guardedness up-to union/concatenation. Without support for up-to corecursion,
these operation must be defined as a composition of primitive ones (and proved being
equal to the standard definitions). As an exercise in coinduction we also prove the
axioms of Kleene algebra for the defined regular operations.

Furthermore, a language for context-free grammars given by productions in Greibach
normal form and an initial nonterminal is constructed by primitive corecursion,
yielding an executable decision procedure for the word problem without further ado.
*}
(*<*)
(* custom coinduction theorem (getting rid of rel_fun) *)
declare language.coinduct[unfolded rel_fun_def, simplified, case_names Lang, coinduct pred]
(*>*)

section {* Regular Languages *}

primcorec Zero :: "'a language" where
  "\<oo> Zero = False"
| "\<dd> Zero = (\<lambda>_. Zero)"

primcorec One :: "'a language" where
  "\<oo> One = True"
| "\<dd> One = (\<lambda>_. Zero)"

primcorec Atom :: "'a \<Rightarrow> 'a language" where
  "\<oo> (Atom a) = False"
| "\<dd> (Atom a) = (\<lambda>b. if a = b then One else Zero)"

primcorec Plus :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
  "\<oo> (Plus r s) = (\<oo> r \<or> \<oo> s)"
| "\<dd> (Plus r s) = (\<lambda>a. Plus (\<dd> r a) (\<dd> s a))"

theorem Plus_ZeroL[simp]: "Plus Zero r = r"
  by (coinduction arbitrary: r) simp

theorem Plus_ZeroR[simp]: "Plus r Zero = r"
  by (coinduction arbitrary: r) simp

theorem Plus_comm: "Plus r s = Plus s r"
  by (coinduction arbitrary: r s) auto

lemma Plus_rotate: "Plus r (Plus s t) = Plus s (Plus r t)"
  using Plus_assoc Plus_comm by metis

theorem Plus_idem: "Plus r r = r"
  by (coinduction arbitrary: r) auto

lemma Plus_idem_assoc: "Plus r (Plus r s) = Plus r s"
  by (metis Plus_assoc Plus_idem)

lemmas Plus_ACI[simp] = Plus_rotate Plus_comm Plus_assoc Plus_idem_assoc Plus_idem

text {*
  Coinduction up-to @{term Plus}--congruence relaxes the coinduction hypothesis by requiring
  membership in the congruence closure of the bisimulation rather than in the bisimulation itself.
*}

inductive Plus_cong where
  Refl[intro]: "x = y \<Longrightarrow> Plus_cong R x y"
| Base[intro]: "R x y \<Longrightarrow> Plus_cong R x y"
| Trans[intro]: "Plus_cong R x y \<Longrightarrow> Plus_cong R y z \<Longrightarrow> Plus_cong R x z"
| Plus[intro]: "\<lbrakk>Plus_cong R x y; Plus_cong R x' y'\<rbrakk> \<Longrightarrow> Plus_cong R (Plus x x') (Plus y y')"

lemma language_coinduct_upto_Plus[unfolded rel_fun_def, simplified, case_names Lang, consumes 1]:
  assumes R: "R L K" and hyp:
    "(\<And>L K. R L K \<Longrightarrow> \<oo> L = \<oo> K \<and> rel_fun op = (Plus_cong R) (\<dd> L) (\<dd> K))"
  shows "L = K"
proof (coinduct rule: language.coinduct[of "Plus_cong R"])
  fix L K assume "Plus_cong R L K"
  then show "\<oo> L = \<oo> K \<and> rel_fun op = (Plus_cong R) (\<dd> L) (\<dd> K)" using hyp
    by (induct rule: Plus_cong.induct) (auto simp: rel_fun_def)
qed (intro Base R)

lemma Plus_OneL[simp]: "\<oo> r \<Longrightarrow> Plus One r = r"
  by (coinduction arbitrary: r rule: language_coinduct_upto_Plus) auto

lemma Plus_OneR[simp]: "\<oo> r \<Longrightarrow> Plus r One = r"
  by (coinduction arbitrary: r rule: language_coinduct_upto_Plus) auto

text {*
  Concatenation is not primitively corecursive---the corecursive call of its derivative is
  guarded by @{term Plus}. However, it can be defined as a composition of two primitively
  corecursive functions.
*}

primcorec TimesLR :: "'a language \<Rightarrow> 'a language \<Rightarrow> ('a \<times> bool) language" where
  "\<oo> (TimesLR r s) = (\<oo> r \<and> \<oo> s)"
| "\<dd> (TimesLR r s) = (\<lambda>(r, s). TimesLR r s) o (\<lambda>(a, b).
   (if b then (\<dd> r a, s) else if \<oo> r then (\<dd> s a, One) else (Zero, One)))"

primcorec Times_Plus :: "('a \<times> bool) language \<Rightarrow> 'a language" where
  "\<oo> (Times_Plus r) = \<oo> r"
| "\<dd> (Times_Plus r) = (\<lambda>a. Times_Plus (Plus (\<dd> r (a, True)) (\<dd> r (a, False))))"

lemma TimesLR_ZeroL[simp]: "TimesLR Zero r = Zero"
  by (coinduction arbitrary: r) auto

lemma TimesLR_ZeroR[simp]: "TimesLR r Zero = Zero"
  by (coinduction arbitrary: r) (auto intro: exI[of _ Zero])

lemma TimesLR_PlusL[simp]: "TimesLR (Plus r s) t = Plus (TimesLR r t) (TimesLR s t)"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus) auto

lemma TimesLR_PlusR[simp]: "TimesLR r (Plus s t) = Plus (TimesLR r s) (TimesLR r t)"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus) auto

lemma Times_Plus_Zero[simp]: "Times_Plus Zero = Zero"
  by coinduction simp

lemma Times_Plus_Plus[simp]: "Times_Plus (Plus r s) = Plus (Times_Plus r) (Times_Plus s)"
proof (coinduction arbitrary: r s)
  case (Lang r s)
  then show ?case unfolding Times_Plus.sel Plus.sel
    by (intro conjI[OF refl] allI exI conjI[rotated], rule refl) (metis Plus_comm Plus_rotate)
qed

lemma Times_Plus_TimesLR_One[simp]: "Times_Plus (TimesLR r One) = r"
  by (coinduction arbitrary: r) simp

lemma Times_Plus_TimesLR_PlusL[simp]:
  "Times_Plus (TimesLR (Plus r s) t) = Plus (Times_Plus (TimesLR r t)) (Times_Plus (TimesLR s t))"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus) auto

lemma Times_Plus_TimesLR_PlusR[simp]:
  "Times_Plus (TimesLR r (Plus s t)) = Plus (Times_Plus (TimesLR r s)) (Times_Plus (TimesLR r t))"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus) auto

definition Times :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
  "Times r s = Times_Plus (TimesLR r s)"

lemma \<oo>_Times[simp]:
  "\<oo> (Times r s) = (\<oo> r \<and> \<oo> s)"
  unfolding Times_def by simp

lemma \<dd>_Times[simp]:
  "\<dd> (Times r s) = (\<lambda>a. if \<oo> r then Plus (Times (\<dd> r a) s) (\<dd> s a) else Times (\<dd> r a) s)"
  unfolding Times_def by (rule ext, coinduction arbitrary: r s rule: language_coinduct_upto_Plus) auto

theorem Times_ZeroL[simp]: "Times Zero r = Zero"
  by coinduction simp

theorem Times_ZeroR[simp]: "Times r Zero = Zero"
  by (coinduction arbitrary: r) auto

theorem Times_OneR[simp]: "Times r One = r"
  by (coinduction arbitrary: r) simp

theorem Times_PlusL[simp]: "Times (Plus r s) t = Plus (Times r t) (Times s t)"
  by (coinduction arbitrary: r s rule: language_coinduct_upto_Plus) fastforce

theorem Times_PlusR[simp]: "Times r (Plus s t) = Plus (Times r s) (Times r t)"
  by (coinduction arbitrary: r s rule: language_coinduct_upto_Plus) fastforce

text {*
  Similarly to @{term Times}, iteration is not primitively corecursive (guardedness by
  @{term Times} is required). We apply a similar trick to obtain its definition.
*}

primcorec StarLR :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
  "\<oo> (StarLR r s) = \<oo> r"
| "\<dd> (StarLR r s) = (\<lambda>a. StarLR (\<dd> (Times r (Plus One s)) a) s)"

lemma StarLR_Zero[simp]: "StarLR Zero r = Zero"
  by coinduction auto

lemma StarLR_Plus[simp]: "StarLR (Plus r s) t = Plus (StarLR r t) (StarLR s t)"
  by (coinduction arbitrary: r s) (auto simp del: Plus_ACI Times_PlusR)

lemma StarLR_Times_Plus_One[simp]: "StarLR (Times r (Plus One s)) s = StarLR r s"
proof (coinduction arbitrary: r s)
  case Lang
  { fix a
    def L \<equiv> "Plus (\<dd> r a) (Plus (Times (\<dd> r a) s) (\<dd> s a))"
    and R \<equiv> "Times (Plus (\<dd> r a) (Plus (Times (\<dd> r a) s) (\<dd> s a))) s"
    have "Plus L (Plus R (\<dd> s a)) = Plus (Plus L (\<dd> s a)) R" by (metis Plus_assoc Plus_comm)
    also have "Plus L (\<dd> s a) = L" unfolding L_def by simp
    finally have "Plus L (Plus R (\<dd> s a)) = Plus L R" .
  }
  then show ?case by (auto simp del: StarLR_Plus Plus_assoc Times_PlusL)
qed

lemma StarLR_Times: "StarLR (Times r s) t = Times r (StarLR s t)"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus)
    (fastforce simp del: Plus_ACI Times_PlusR)

definition Star :: "'a language \<Rightarrow> 'a language" where
  "Star r = StarLR One r"

lemma \<oo>_Star[simp]: "\<oo> (Star r)"
  unfolding Star_def by simp

lemma \<dd>_Star[simp]: "\<dd> (Star r) = (\<lambda>a. Times (\<dd> r a) (Star r))"
  unfolding Star_def by (rule ext, coinduction arbitrary: r rule: language_coinduct_upto_Plus)
    (auto simp add: Star_def StarLR_Times[symmetric])

lemma Star_Zero[simp]: "Star Zero = One"
  by (coinduction rule: language.coinduct_strong) auto

lemma Star_One[simp]: "Star One = One"
  by (coinduction rule: language.coinduct_strong) auto

lemma Star_unfoldL: "Star r = Plus One (Times r (Star r))"
  by (coinduction arbitrary: r rule: language_coinduct_upto_Plus) auto

primcorec Inter :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
  "\<oo> (Inter r s) = (\<oo> r \<and> \<oo> s)"
| "\<dd> (Inter r s) = (\<lambda>a. Inter (\<dd> r a) (\<dd> s a))"

primcorec Not :: "'a language \<Rightarrow> 'a language" where
  "\<oo> (Not r) = (\<not> \<oo> r)"
| "\<dd> (Not r) = (\<lambda>a. Not (\<dd> r a))"

primcorec Full :: "'a language" ("\<Sigma>\<^sup>*") where
  "\<oo> Full = True"
| "\<dd> Full = (\<lambda>_. Full)"

text {*
  Shuffle product is not primitively corecursive---the corecursive call of its derivative is
  guarded by @{term Plus}. However, it can be defined as a composition of two primitively
  corecursive functions.
*}

primcorec ShuffleLR :: "'a language \<Rightarrow> 'a language \<Rightarrow> ('a \<times> bool) language" where
  "\<oo> (ShuffleLR r s) = (\<oo> r \<and> \<oo> s)"
| "\<dd> (ShuffleLR r s) = (\<lambda>(r, s). ShuffleLR r s) o (\<lambda>(a, b). (if b then (\<dd> r a, s) else (r, \<dd> s a)))"

primcorec Shuffle_Plus :: "('a \<times> bool) language \<Rightarrow> 'a language" where
  "\<oo> (Shuffle_Plus r) = \<oo> r"
| "\<dd> (Shuffle_Plus r) = (\<lambda>a. Shuffle_Plus (Plus (\<dd> r (a, True)) (\<dd> r (a, False))))"

lemma ShuffleLR_ZeroL[simp]: "ShuffleLR Zero r = Zero"
  by (coinduction arbitrary: r) auto

lemma ShuffleLR_ZeroR[simp]: "ShuffleLR r Zero = Zero"
  by (coinduction arbitrary: r) (auto intro: exI[of _ Zero])

lemma ShuffleLR_PlusL[simp]: "ShuffleLR (Plus r s) t = Plus (ShuffleLR r t) (ShuffleLR s t)"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus) auto

lemma ShuffleLR_PlusR[simp]: "ShuffleLR r (Plus s t) = Plus (ShuffleLR r s) (ShuffleLR r t)"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus) auto

lemma Shuffle_Plus_Zero[simp]: "Shuffle_Plus Zero = Zero"
  by coinduction simp

lemma Shuffle_Plus_Plus[simp]: "Shuffle_Plus (Plus r s) = Plus (Shuffle_Plus r) (Shuffle_Plus s)"
proof (coinduction arbitrary: r s)
  case (Lang r s)
  then show ?case unfolding Shuffle_Plus.sel Plus.sel
    by (intro conjI[OF refl] allI exI conjI[rotated], rule refl) (metis Plus_comm Plus_rotate)
qed

lemma Shuffle_Plus_ShuffleLR_One[simp]: "Shuffle_Plus (ShuffleLR r One) = r"
  by (coinduction arbitrary: r) simp

lemma Shuffle_Plus_ShuffleLR_PlusL[simp]:
  "Shuffle_Plus (ShuffleLR (Plus r s) t) = Plus (Shuffle_Plus (ShuffleLR r t)) (Shuffle_Plus (ShuffleLR s t))"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus) auto

lemma Shuffle_Plus_ShuffleLR_PlusR[simp]:
  "Shuffle_Plus (ShuffleLR r (Plus s t)) = Plus (Shuffle_Plus (ShuffleLR r s)) (Shuffle_Plus (ShuffleLR r t))"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus) auto

definition Shuffle :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
  "Shuffle r s = Shuffle_Plus (ShuffleLR r s)"

lemma \<oo>_Shuffle[simp]:
  "\<oo> (Shuffle r s) = (\<oo> r \<and> \<oo> s)"
  unfolding Shuffle_def by simp

lemma \<dd>_Shuffle[simp]:
  "\<dd> (Shuffle r s) = (\<lambda>a. Plus (Shuffle (\<dd> r a) s) (Shuffle r (\<dd> s a)))"
  unfolding Shuffle_def by (rule ext, coinduction arbitrary: r s rule: language_coinduct_upto_Plus) auto

theorem Shuffle_ZeroL[simp]: "Shuffle Zero r = Zero"
  by (coinduction arbitrary: r rule: language_coinduct_upto_Plus) (auto 0 4)

theorem Shuffle_ZeroR[simp]: "Shuffle r Zero = Zero"
  by (coinduction arbitrary: r rule: language_coinduct_upto_Plus) (auto 0 4)

theorem Shuffle_OneL[simp]: "Shuffle One r = r"
  by (coinduction arbitrary: r rule: language.coinduct_strong) (simp add: rel_fun_def)

theorem Shuffle_OneR[simp]: "Shuffle r One = r"
  by (coinduction arbitrary: r) simp

theorem Shuffle_PlusL[simp]: "Shuffle (Plus r s) t = Plus (Shuffle r t) (Shuffle s t)"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus)
    (force intro!: Trans[OF Plus[OF Base Base] Refl])

theorem Shuffle_PlusR[simp]: "Shuffle r (Plus s t) = Plus (Shuffle r s) (Shuffle r t)"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus)
    (force intro!: Trans[OF Plus[OF Base Base] Refl])

theorem Shuffle_assoc[simp]: "Shuffle (Shuffle r s) t = Shuffle r (Shuffle s t)"
  by (coinduction arbitrary: r s t rule: language_coinduct_upto_Plus) fastforce

text {*
  We generalize coinduction up-to @{term Plus} to coinduction up-to all previously defined concepts.
*}

inductive regular_cong where
  Refl[intro]: "x = y \<Longrightarrow> regular_cong R x y"
| Sym[intro]: "regular_cong R x y \<Longrightarrow> regular_cong R y x"
| Trans[intro]: "\<lbrakk>regular_cong R x y; regular_cong R y z\<rbrakk> \<Longrightarrow> regular_cong R x z"
| Base[intro]: "R x y \<Longrightarrow> regular_cong R x y"
| Plus[intro]: "\<lbrakk>regular_cong R x y; regular_cong R x' y'\<rbrakk> \<Longrightarrow>
    regular_cong R (Plus x x') (Plus y y')"
| Times[intro]: "\<lbrakk>regular_cong R x y; regular_cong R x' y'\<rbrakk> \<Longrightarrow>
    regular_cong R (Times x x') (Times y y')"
| Star[intro]: "\<lbrakk>regular_cong R x y\<rbrakk> \<Longrightarrow>
    regular_cong R (Star x) (Star y)"
| Inter[intro]: "\<lbrakk>regular_cong R x y; regular_cong R x' y'\<rbrakk> \<Longrightarrow>
    regular_cong R (Inter x x') (Inter y y')"
| Not[intro]: "\<lbrakk>regular_cong R x y\<rbrakk> \<Longrightarrow>
    regular_cong R (Not x) (Not y)"
| Shuffle[intro]: "\<lbrakk>regular_cong R x y; regular_cong R x' y'\<rbrakk> \<Longrightarrow>
    regular_cong R (Shuffle x x') (Shuffle y y')"

lemma language_coinduct_upto_regular[unfolded rel_fun_def, simplified, case_names Lang, consumes 1]:
  assumes R: "R L K" and hyp:
    "(\<And>L K. R L K \<Longrightarrow> \<oo> L = \<oo> K \<and> rel_fun op = (regular_cong R) (\<dd> L) (\<dd> K))"
  shows "L = K"
proof (coinduct rule: language.coinduct[of "regular_cong R"])
  fix L K assume "regular_cong R L K"
  then show "\<oo> L = \<oo> K \<and> rel_fun op = (regular_cong R) (\<dd> L) (\<dd> K)" using hyp
    by (induct rule: regular_cong.induct) (auto simp: rel_fun_def)
qed (intro Base R)

lemma Star_unfoldR: "Star r = Plus One (Times (Star r) r)"
proof (coinduction arbitrary: r rule: language_coinduct_upto_regular)
  case Lang
  { fix a have "Plus (Times (\<dd> r a) (Times (Star r) r)) (\<dd> r a) =
      Times (\<dd> r a) (Plus One (Times (Star r) r))" by simp
  }
  then show ?case by (auto simp del: Times_PlusR)
qed

lemma Star_Star[simp]: "Star (Star r) = Star r"
  by (subst Star_unfoldL, coinduction arbitrary: r rule: language_coinduct_upto_regular) auto

lemma Times_Star[simp]: "Times (Star r) (Star r) = Star r"
proof (coinduction arbitrary: r rule: language_coinduct_upto_regular)
  case Lang
  have *: "\<And>r s. Plus (Times r s) r = Times r (Plus s One)" by simp
  show ?case by (auto simp del: Times_PlusR Plus_ACI simp: Times_PlusR[symmetric] *)
qed

instantiation language :: (type) "{semiring_1, order}"
begin

lemma Zero_One[simp]: "Zero \<noteq> One"
  by (metis One.simps(1) Zero.simps(1))

definition "zero_language = Zero"
definition "one_language = One"
definition "plus_language = Plus"
definition "times_language = Times"

definition "less_eq_language r s = (Plus r s = s)"
definition "less_language r s = (Plus r s = s \<and> r \<noteq> s)"

lemmas language_defs = zero_language_def one_language_def plus_language_def times_language_def
  less_eq_language_def less_language_def

instance proof intro_classes
  fix x y z :: "'a language" assume "x \<le> y" "y \<le> z"
  then show "x \<le> z" unfolding language_defs by (metis Plus_assoc)
next
  fix x y z :: "'a language"
  show "x + y + z = x + (y + z)" unfolding language_defs by (rule Plus_assoc)
qed (auto simp: language_defs)

end

text {*
  We prove the missing axioms of Kleene Algebras about @{term Star}, as well as monotonicity
  properties and three standard interesting rules: bisimulation, sliding, and denesting.
*}

theorem le_StarL: "Plus One (Times r (Star r)) \<le> Star r"
  by (rule order_eq_refl[OF Star_unfoldL[symmetric]])

theorem le_StarR: "Plus One (Times (Star r) r) \<le> Star r"
  by (rule order_eq_refl[OF Star_unfoldR[symmetric]])

theorem ardenL: "Plus r (Times s x) \<le> x \<Longrightarrow> Times (Star s) r \<le> x"
unfolding language_defs
proof (coinduction arbitrary: r s x rule: language_coinduct_upto_regular)
  case Lang
  hence "\<oo> r \<Longrightarrow> \<oo> x" by (metis Plus.sel(1))
  moreover
  { fix a
    let ?R = "(\<lambda>L K. \<exists>r s.  L = Plus (Times (Star s) r) K \<and> Plus r (Plus (Times s K) K) = K)"
    have "regular_cong ?R (Plus x (Times (Star s) r)) x"
      using Lang[unfolded Plus_assoc] by (auto simp only: Plus_comm)
    hence "regular_cong ?R
      (Plus (Times (\<dd> s a) (Plus x (Times (Star s) r))) (Plus (\<dd> r a) (\<dd> x a)))
      (Plus (\<dd> r a) (Plus (Times (\<dd> s a) x) (\<dd> x a)))"
      by (auto simp del: Times_PlusR)
    also have "(Plus (Times (\<dd> s a) (Plus x (Times (Star s) r))) (Plus (\<dd> r a) (\<dd> x a))) =
      (Plus (Times (\<dd> s a) (Times (Star s) r)) (Plus (\<dd> r a) (\<dd> x a)))"
      by (subst (3) Lang[symmetric]) auto
    finally have "regular_cong ?R
      (Plus (Times (\<dd> s a) (Times (Star s) r)) (Plus (\<dd> r a) (\<dd> x a)))
      (Plus (\<dd> r a) (Plus (Times (\<dd> s a) x) (\<dd> x a)))" .
  }
  ultimately show ?case by (subst (4) Lang[symmetric]) auto
qed

theorem ardenR: "Plus r (Times x s) \<le> x \<Longrightarrow> Times r (Star s) \<le> x"
unfolding language_defs
proof (coinduction arbitrary: r s x rule: language_coinduct_upto_regular)
  case Lang
  let ?R = "(\<lambda>L K. \<exists>r s. L = Plus (Times r (Star s)) K \<and> Plus r (Plus (Times K s) K) = K)"
  have "\<And>a. \<oo> x \<Longrightarrow> Plus (\<dd> s a) (\<dd> x a) = \<dd> x a"
    by (subst (1 2) Lang[symmetric]) auto
  then have *: "\<And>a. ?R (Plus (Times (\<dd> r a) (Star s)) (\<dd> x a)) (\<dd> x a)"
    by (subst Lang[symmetric]) (auto simp del: Plus_comm)
  moreover
  from Lang have "\<oo> r \<Longrightarrow> \<oo> x" by (metis Plus.sel(1))
  moreover
  { fix a assume "\<oo> x"
    have "regular_cong ?R (Plus (Times (\<dd> s a) (Star s)) (\<dd> x a)) (\<dd> x a)"
    proof (rule Base exI conjI[OF refl])+
      from `\<oo> x` show "Plus (\<dd> s a) (Plus (Times (\<dd> x a) s) (\<dd> x a)) = \<dd> x a"
        by (subst (1 3) Lang[symmetric]) auto
    qed
    from Plus[OF Base[of ?R, OF *[of a]] this] have "regular_cong ?R
      (Plus (Times (\<dd> r a) (Star s)) (Plus (Times (\<dd> s a) (Star s)) (\<dd> x a))) (\<dd> x a)" by auto
  }
  ultimately show ?case by auto
qed

lemma ge_One[simp]: "One \<le> r \<longleftrightarrow> \<oo> r"
  unfolding less_eq_language_def by (metis One.sel(1) Plus.sel(1) Plus_OneL)

lemma Plus_mono[intro]: "\<lbrakk>r1 \<le> s1; r2 \<le> s2\<rbrakk> \<Longrightarrow> Plus r1 r2 \<le> Plus s1 s2"
  unfolding less_eq_language_def by (metis Plus_assoc Plus_comm)

lemma Plus_upper: "\<lbrakk>r1 \<le> s; r2 \<le> s\<rbrakk> \<Longrightarrow> Plus r1 r2 \<le> s"
  by (metis Plus_mono Plus_idem)

lemma le_PlusL: "r \<le> Plus r s"
  by (metis Plus_idem_assoc less_eq_language_def)

lemma le_PlusR: "s \<le> Plus r s"
  by (metis Plus_comm Plus_idem_assoc less_eq_language_def)

lemma Times_mono[intro]: "\<lbrakk>r1 \<le> s1; r2 \<le> s2\<rbrakk> \<Longrightarrow> Times r1 r2 \<le> Times s1 s2"
proof (unfold less_eq_language_def)
  assume s1[symmetric]: "Plus r1 s1 = s1" and s2[symmetric]: "Plus r2 s2 = s2"
  have "Plus (Times r1 r2) (Times s1 s2) =
    Plus (Times r1 r2) (Plus (Times r1 r2) (Plus (Times s1 r2) (Plus (Times r1 s2) (Times s1 s2))))"
    by (subst s1, subst s2) auto
  also have "\<dots> = Plus (Times r1 r2) (Plus (Times s1 r2) (Plus (Times r1 s2) (Times s1 s2)))"
    by (metis Plus_idem Plus_assoc)
  also have "\<dots> = Times s1 s2" by (subst s1, subst s2) auto
  finally show "Plus (Times r1 r2) (Times s1 s2) = Times s1 s2" .
qed

lemma le_TimesL: "\<oo> s \<Longrightarrow> r \<le> Times r s"
  by (metis Plus_OneL Times_OneR Times_mono le_PlusL order_refl)

lemma le_TimesR: "\<oo> r \<Longrightarrow> s \<le> Times r s"
  by (metis Plus_OneR Times_OneL Times_mono le_PlusR order_refl)

lemma le_Star: "s \<le> Star s"
  by (subst Star_unfoldL, subst Star_unfoldL) (auto intro: order_trans[OF le_PlusL le_PlusR])

lemma Star_mono:
  assumes rs: "r \<le> s"
  shows "Star r \<le> Star s"
proof -
  have "Star r = Plus One (Times (Star r) r)" by (rule Star_unfoldR)
  also have "\<dots> \<le> Plus One (Times (Star r) s)" by (blast intro: rs)
  also have "Times (Star r) s \<le> Star s"
  proof (rule ardenL[OF Plus_upper[OF le_Star]])
    have "Times r (Star s) \<le> Times s (Star s)" by (blast intro: rs)
    also have "Times s (Star s) \<le> Plus One (Times s (Star s))" by (rule le_PlusR)
    finally show "Times r (Star s) \<le> Star s" by (subst (2) Star_unfoldL)
  qed
  finally show ?thesis by auto
qed

lemma Inter_mono: "\<lbrakk>r1 \<le> s1; r2 \<le> s2\<rbrakk> \<Longrightarrow> Inter r1 r2 \<le> Inter s1 s2"
unfolding less_eq_language_def proof (coinduction arbitrary: r1 r2 s1 s2)
  case Lang
  then have "\<oo> (Plus r1 s1) = \<oo> s1" "\<oo> (Plus r2 s2) = \<oo> s2"
        "\<forall>a. \<dd> (Plus r1 s1) a = \<dd> s1 a" "\<forall>a. \<dd> (Plus r2 s2) a = \<dd> s2 a" by simp_all
  then show ?case by fastforce
qed

lemma Not_antimono: "r \<le> s \<Longrightarrow> Not s \<le> Not r"
unfolding less_eq_language_def proof (coinduction arbitrary: r s)
  case Lang
  then have "\<oo> (Plus r s) = \<oo> s" "\<forall>a. \<dd> (Plus r s) a = \<dd> s a" by simp_all
  then show ?case by auto
qed

lemma Not_Plus[simp]: "Not (Plus r s) = Inter (Not r) (Not s)"
  by (coinduction arbitrary: r s) auto

lemma Not_Inter[simp]: "Not (Inter r s) = Plus (Not r) (Not s)"
  by (coinduction arbitrary: r s) auto

lemma Inter_assoc[simp]: "Inter (Inter r s) t = Inter r (Inter s t)"
  by (coinduction arbitrary: r s t) auto

lemma Inter_comm: "Inter r s = Inter s r"
  by (coinduction arbitrary: r s) auto

lemma Inter_idem[simp]: "Inter r r = r"
  by (coinduction arbitrary: r) auto

lemma Inter_ZeroL[simp]: "Inter Zero r = Zero"
  by (coinduction arbitrary: r) auto

lemma Inter_ZeroR[simp]: "Inter r Zero = Zero"
  by (coinduction arbitrary: r) auto

lemma Inter_FullL[simp]: "Inter Full r = r"
  by (coinduction arbitrary: r) auto

lemma Inter_FullR[simp]: "Inter r Full = r"
  by (coinduction arbitrary: r) auto

lemma Plus_FullL[simp]: "Plus Full r = Full"
  by (coinduction arbitrary: r) auto

lemma Plus_FullR[simp]: "Plus r Full = Full"
  by (coinduction arbitrary: r) auto

lemma Not_Not[simp]: "Not (Not r) = r"
  by (coinduction arbitrary: r) auto

lemma Not_Zero[simp]: "Not Zero = Full"
  by coinduction simp

lemma Not_Full[simp]: "Not Full = Zero"
  by coinduction simp

lemma bisimulation:
  assumes "Times r s = Times s t"
  shows "Times (Star r) s = Times s (Star t)"
proof (rule antisym[OF ardenL[OF Plus_upper[OF le_TimesL]] ardenR[OF Plus_upper[OF le_TimesR]]])
  have "Times r (Times s (Star t)) = Times s (Times t (Star t))" (is "?L = _")
    by (simp only: assms Times_assoc[symmetric])
  also have "\<dots> \<le> Times s (Star t)" (is "_ \<le> ?R")
    by (rule Times_mono[OF order_refl ord_le_eq_trans[OF le_PlusR Star_unfoldL[symmetric]]])
  finally show "?L \<le> ?R" .
next
  have "Times (Times (Star r) s) t = Times (Times (Star r) r) s" (is "?L = _")
    by (simp only: assms Times_assoc)
  also have "\<dots> \<le> Times (Star r) s" (is "_ \<le> ?R")
    by (rule Times_mono[OF ord_le_eq_trans[OF le_PlusR Star_unfoldR[symmetric]] order_refl])
  finally show "?L \<le> ?R" .
qed simp_all

lemma sliding: "Times (Star (Times r s)) r = Times r (Star (Times s r))"
proof (rule antisym[OF ardenL[OF Plus_upper[OF le_TimesL]] ardenR[OF Plus_upper[OF le_TimesR]]])
  have "Times (Times r s) (Times r (Star (Times s r))) =
    Times r (Times (Times s r) (Star (Times s r)))" (is "?L = _") by simp
  also have "\<dots> \<le> Times r (Star (Times s r))" (is "_ \<le> ?R")
    by (rule Times_mono[OF order_refl ord_le_eq_trans[OF le_PlusR Star_unfoldL[symmetric]]])
  finally show "?L \<le> ?R" .
next
  have "Times (Times (Star (Times r s)) r) (Times s r) =
    Times (Times (Star (Times r s)) (Times r s)) r" (is "?L = _") by simp
  also have "\<dots> \<le> Times (Star (Times r s)) r" (is "_ \<le> ?R")
    by (rule Times_mono[OF ord_le_eq_trans[OF le_PlusR Star_unfoldR[symmetric]] order_refl])
  finally show "?L \<le> ?R" .
qed simp_all

lemma denesting: "Star (Plus r s) = Times (Star r) (Star (Times s (Star r)))"
proof (rule antisym[OF _ ardenR[OF Plus_upper[OF Star_mono[OF le_PlusL]]]])
  have "Star (Plus r s) = Times (Star (Plus r s)) One" by simp
  also have "\<dots> \<le> Times (Star r) (Star (Times s (Star r)))"
  proof (rule ardenL[OF Plus_upper])
    show "Times (Plus r s) (Times (Star r) (Star (Times s (Star r)))) \<le>
      Times (Star r) (Star (Times s (Star r)))" (is "Times _ ?L \<le> ?R")
    proof (subst Times_PlusL, rule Plus_upper)
      show "Times s ?L \<le> ?R"
        by (subst (5) Star_unfoldL, rule order_trans[OF order_trans[OF _ le_PlusR] le_TimesR]) auto
    qed (subst (4) Times_Star[symmetric], auto simp del: Times_Star intro: le_Star)
  qed simp
  finally show "Star (Plus r s) \<le> Times (Star r) (Star (Times s (Star r)))" .
next
  have "Times (Star (Plus r s)) (Times s (Star r)) \<le> Times (Star (Plus r s)) (Star (Plus r s))"
    by (subst (4) Star_unfoldL, rule Times_mono[OF order_refl
      order_trans[OF Times_mono[OF le_PlusR Star_mono[OF le_PlusL]] le_PlusR]])
  also have "\<dots> = Star (Plus r s)" by simp
  finally show "Times (Star (Plus r s)) (Times s (Star r)) \<le> Star (Plus r s)" .
qed

text {*
It is useful to lift binary operators @{term Plus} and @{term Times}
to $n$-ary operators (that take a list as input).
*}

definition PLUS :: "'a language list \<Rightarrow> 'a language" where
  "PLUS xs \<equiv> foldr Plus xs Zero"

lemma \<oo>_foldr_Plus: "\<oo> (foldr Plus xs s) = (\<exists>x\<in>set (s # xs). \<oo> x)"
  by (induct xs arbitrary: s) auto

lemma \<dd>_foldr_Plus: "\<dd> (foldr Plus xs s) a = foldr Plus (map (\<lambda>r. \<dd> r a) xs) (\<dd> s a)"
  by (induct xs arbitrary: s) simp_all

lemma \<dd>_PLUS[simp]: "\<dd> (PLUS xs) a = PLUS (map (\<lambda>r. \<dd> r a) xs)"
  unfolding PLUS_def \<dd>_foldr_Plus by simp

definition TIMES :: "'a language list \<Rightarrow> 'a language" where
  "TIMES xs \<equiv> foldr Times xs One"

lemma \<oo>_foldr_Times: "\<oo> (foldr Times xs s) = (\<forall>x\<in>set (s # xs). \<oo> x)"
  by (induct xs) (auto simp: PLUS_def)

primrec tails where
  "tails [] = [[]]"
| "tails (x # xs) = (x # xs) # tails xs"

lemma tails_snoc[simp]: "tails (xs @ [x]) = map (\<lambda>ys. ys @ [x]) (tails xs) @ [[]]"
  by (induct xs) auto

lemma length_tails[simp]: "length (tails xs) = Suc (length xs)"
  by (induct xs) auto

lemma \<dd>_foldr_Times: "\<dd> (foldr Times xs s) a =
  (let n = length (takeWhile \<oo> xs)
  in PLUS (map (\<lambda>zs. TIMES (\<dd> (hd zs) a # tl zs)) (take (Suc n) (tails (xs @ [s])))))"
  by (induct xs) (auto simp: TIMES_def PLUS_def Let_def foldr_map o_def)

lemma \<oo>_TIMES[simp]: "\<oo> (TIMES xs) = (\<forall>x\<in>set xs. \<oo> x)"
  unfolding TIMES_def \<oo>_foldr_Times by simp

lemma TIMES_snoc_One[simp]: "TIMES (xs @ [One]) = TIMES xs"
  by (induct xs) (auto simp: TIMES_def)

lemma \<dd>_TIMES[simp]: "\<dd> (TIMES xs) a = (let n = length (takeWhile \<oo> xs)
  in PLUS (map (\<lambda>zs. TIMES (\<dd> (hd zs) a # tl zs)) (take (Suc n) (tails (xs @ [One])))))"
  unfolding TIMES_def \<dd>_foldr_Times by simp

section {* Context Free Languages *}

context
fixes init :: "'n::enum"
and   prod :: "'n \<Rightarrow> ('t + 'n) language"
begin

primcorec deep_subst :: "('t + 'n) language \<Rightarrow> 't language" where
  "deep_subst r =
     (let shallow_subst = PLUS (r # map (\<lambda>N. Times (prod N) (\<dd> r (Inr N))) Enum.enum)
     in Lang (\<oo> shallow_subst) (\<lambda>a. deep_subst (\<dd> shallow_subst (Inl a))))"

definition subst where
  "subst = deep_subst (prod init)"

end

text {*
A context-free grammar consists of a list of productions for every nonterminal
and an initial nonterminal. The productions are required to be in weak Greibach
normal form, i.e. each right hand side of a production must either be empty or
start with a terminal.
*}

locale cfg =
fixes init :: "'n::enum"
and   prod :: "'n \<Rightarrow> ('t + 'n) list list"
assumes weakGreibach: "\<forall>N. \<forall>rhs \<in> set (prod N). case rhs of (Inr N # _) \<Rightarrow> False | _ \<Rightarrow> True"
begin

abbreviation lang :: "'t language" where
  "lang \<equiv> subst init (\<lambda>N. PLUS (map (TIMES o map Atom) (prod N)))"

end

section {* Word-theoretic Semantics of Languages *}

text {*
We show our @{type language} codatatype being isomorphic to the standard
language representation as a set of lists.
*}

primrec in_language :: "'a language \<Rightarrow> 'a list \<Rightarrow> bool" where
  "in_language L [] = \<oo> L"
| "in_language L (x # xs) = in_language (\<dd> L x) xs"

primcorec to_language :: "'a list set \<Rightarrow> 'a language" where
  "\<oo> (to_language L) = ([] \<in> L)"
| "\<dd> (to_language L) = (\<lambda>a. to_language {w. a # w \<in> L})"

lemma in_language_to_language[simp]: "Collect (in_language (to_language L)) = L"
proof (rule set_eqI, unfold mem_Collect_eq)
  fix w show "in_language (to_language L) w = (w \<in> L)" by (induct w arbitrary: L) auto
qed

lemma to_language_in_language[simp]: "to_language (Collect (in_language L)) = L"
  by (coinduction arbitrary: L) auto

lemma in_language_bij: "bij (Collect o in_language)"
proof (rule bijI', unfold o_apply, safe)
  fix L R :: "'a language" assume "Collect (in_language L) = Collect (in_language R)"
  then show "L = R" unfolding set_eq_iff mem_Collect_eq
    by (coinduction arbitrary: L R) (metis in_language.simps)
next
  fix L :: "'a list set"
  have "L = Collect (in_language (to_language L))" by simp
  then show "\<exists>K. L = Collect (in_language K)" by blast
qed

lemma to_language_bij: "bij to_language"
  by (rule o_bij[of "Collect o in_language"]) (simp_all add: fun_eq_iff)

(*<*)
hide_const (open) TimesLR Times_Plus StarLR deep_subst subst

end
(*>*)


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

section \<open> Matrix norms \<close>

text \<open> Here, we explore some properties about the operator and the maximum norms for matrices. \<close>

theory MTX_Norms
  imports MTX_Preliminaries

begin

subsection\<open> Matrix operator norm \<close>

abbreviation op_norm :: "('a::real_normed_algebra_1)^'n^'m \<Rightarrow> real" ("(1\<parallel>_\<parallel>\<^sub>o\<^sub>p)" [65] 61)
  where "\<parallel>A\<parallel>\<^sub>o\<^sub>p \<equiv> onorm (\<lambda>x. A *v x)"

lemma norm_matrix_bound:
  fixes A :: "('a::real_normed_algebra_1)^'n^'m"
  shows "\<parallel>x\<parallel> = 1 \<Longrightarrow> \<parallel>A *v x\<parallel> \<le> \<parallel>(\<chi> i j. \<parallel>A $ i $ j\<parallel>) *v 1\<parallel>"
proof-
  fix x :: "('a, 'n) vec" assume "\<parallel>x\<parallel> = 1"
  hence xi_le1:"\<And>i. \<parallel>x $ i\<parallel> \<le> 1"
    by (metis Finite_Cartesian_Product.norm_nth_le)
  {fix j::'m
    have "\<parallel>(\<Sum>i\<in>UNIV. A $ j $ i * x $ i)\<parallel> \<le> (\<Sum>i\<in>UNIV. \<parallel>A $ j $ i * x $ i\<parallel>)"
      using norm_sum by blast
    also have "... \<le> (\<Sum>i\<in>UNIV. (\<parallel>A $ j $ i\<parallel>) * (\<parallel>x $ i\<parallel>))"
      by (simp add: norm_mult_ineq sum_mono)
    also have "... \<le> (\<Sum>i\<in>UNIV. (\<parallel>A $ j $ i\<parallel>) * 1)"
      using xi_le1 by (simp add: sum_mono mult_left_le)
    finally have "\<parallel>(\<Sum>i\<in>UNIV. A $ j $ i * x $ i)\<parallel> \<le> (\<Sum>i\<in>UNIV. (\<parallel>A $ j $ i\<parallel>) * 1)" by simp}
  hence "\<And>j. \<parallel>(A *v x) $ j\<parallel> \<le> ((\<chi> i1 i2. \<parallel>A $ i1 $ i2\<parallel>) *v 1) $ j"
    unfolding matrix_vector_mult_def by simp
  hence "(\<Sum>j\<in>UNIV. (\<parallel>(A *v x) $ j\<parallel>)\<^sup>2) \<le> (\<Sum>j\<in>UNIV. (\<parallel>((\<chi> i1 i2. \<parallel>A $ i1 $ i2\<parallel>) *v 1) $ j\<parallel>)\<^sup>2)"
    by (metis (mono_tags, lifting) norm_ge_zero power2_abs power_mono real_norm_def sum_mono)
  thus "\<parallel>A *v x\<parallel> \<le> \<parallel>(\<chi> i j. \<parallel>A $ i $ j\<parallel>) *v 1\<parallel>"
    unfolding norm_vec_def L2_set_def by simp
qed

lemma onorm_set_proptys:
  fixes A :: "('a::real_normed_algebra_1)^'n^'m"
  shows "bounded (range (\<lambda>x. (\<parallel>A *v x\<parallel>) / (\<parallel>x\<parallel>)))"
    and "bdd_above (range (\<lambda>x. (\<parallel>A *v x\<parallel>) / (\<parallel>x\<parallel>)))"
    and "(range (\<lambda>x. (\<parallel>A *v x\<parallel>) / (\<parallel>x\<parallel>))) \<noteq> {}"
  unfolding bounded_def bdd_above_def image_def dist_real_def
    apply(rule_tac x=0 in exI)
  by (rule_tac x="\<parallel>(\<chi> i j. \<parallel>A $ i $ j\<parallel>) *v 1\<parallel>" in exI, clarsimp,
      subst mult_norm_matrix_sgn_eq[symmetric], clarsimp,
      rule_tac x="sgn _" in norm_matrix_bound, simp add: norm_sgn)+ force

lemma op_norm_set_proptys:
  fixes A :: "('a::real_normed_algebra_1)^'n^'m"
  shows "bounded {\<parallel>A *v x\<parallel> | x. \<parallel>x\<parallel> = 1}"
    and "bdd_above {\<parallel>A *v x\<parallel> | x. \<parallel>x\<parallel> = 1}"
    and "{\<parallel>A *v x\<parallel> | x. \<parallel>x\<parallel> = 1} \<noteq> {}"
  unfolding bounded_def bdd_above_def apply safe
    apply(rule_tac x=0 in exI, rule_tac x="\<parallel>(\<chi> i j. \<parallel>A $ i $ j\<parallel>) *v 1\<parallel>" in exI)
    apply(force simp: norm_matrix_bound dist_real_def)
   apply(rule_tac x="\<parallel>(\<chi> i j. \<parallel>A $ i $ j\<parallel>) *v 1\<parallel>" in exI, force simp: norm_matrix_bound)
  using ex_norm_eq_1 by blast

lemma op_norm_def: "\<parallel>A\<parallel>\<^sub>o\<^sub>p = Sup {\<parallel>A *v x\<parallel> | x. \<parallel>x\<parallel> = 1}"
  apply(rule antisym[OF onorm_le cSup_least[OF op_norm_set_proptys(3)]])
   apply(case_tac "x = 0", simp)
   apply(subst mult_norm_matrix_sgn_eq[symmetric], simp)
   apply(rule cSup_upper[OF _ op_norm_set_proptys(2)])
   apply(force simp: norm_sgn)
  unfolding onorm_def
  apply(rule cSup_upper[OF _ onorm_set_proptys(2)])
  by (simp add: image_def, clarsimp) (metis div_by_1)

lemma norm_matrix_le_op_norm: "\<parallel>x\<parallel> = 1 \<Longrightarrow> \<parallel>A *v x\<parallel> \<le> \<parallel>A\<parallel>\<^sub>o\<^sub>p"
  apply(unfold onorm_def, rule cSup_upper[OF _ onorm_set_proptys(2)])
  unfolding image_def by (clarsimp, rule_tac x=x in exI) simp

lemma op_norm_ge_0: "0 \<le> \<parallel>A\<parallel>\<^sub>o\<^sub>p"
  using ex_norm_eq_1 norm_ge_zero norm_matrix_le_op_norm basic_trans_rules(23) by blast

lemma norm_sgn_le_op_norm: "\<parallel>A *v sgn x\<parallel> \<le> \<parallel>A\<parallel>\<^sub>o\<^sub>p"
  by (cases "x=0", simp_all add: norm_sgn norm_matrix_le_op_norm op_norm_ge_0)

lemma norm_matrix_le_mult_op_norm: "\<parallel>A *v x\<parallel> \<le> (\<parallel>A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x\<parallel>)"
proof-
  have "\<parallel>A *v x\<parallel> = (\<parallel>A *v sgn x\<parallel>) * (\<parallel>x\<parallel>)"
    by(simp add: mult_norm_matrix_sgn_eq)
  also have "... \<le> (\<parallel>A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x\<parallel>)"
    using norm_sgn_le_op_norm[of A] by (simp add: mult_mono')
  finally show ?thesis by simp
qed

lemma blin_matrix_vector_mult: "bounded_linear ((*v) A)" for A :: "('a::real_normed_algebra_1)^'n^'m"
  by (unfold_locales) (auto intro: norm_matrix_le_mult_op_norm simp:
      mult.commute matrix_vector_right_distrib vector_scaleR_commute)

lemma op_norm_eq_0: "(\<parallel>A\<parallel>\<^sub>o\<^sub>p = 0) = (A = 0)" for A :: "('a::real_normed_field)^'n^'m"
  unfolding onorm_eq_0[OF blin_matrix_vector_mult] using matrix_axis_0[of 1 A] by fastforce

lemma op_norm0: "\<parallel>(0::('a::real_normed_field)^'n^'m)\<parallel>\<^sub>o\<^sub>p = 0"
  using op_norm_eq_0[of 0] by simp

lemma op_norm_triangle: "\<parallel>A + B\<parallel>\<^sub>o\<^sub>p \<le> (\<parallel>A\<parallel>\<^sub>o\<^sub>p) + (\<parallel>B\<parallel>\<^sub>o\<^sub>p)"
  using onorm_triangle[OF blin_matrix_vector_mult[of A] blin_matrix_vector_mult[of B]]
    matrix_vector_mult_add_rdistrib[symmetric, of A _ B] by simp

lemma op_norm_scaleR: "\<parallel>c *\<^sub>R A\<parallel>\<^sub>o\<^sub>p = \<bar>c\<bar> * (\<parallel>A\<parallel>\<^sub>o\<^sub>p)"
  unfolding onorm_scaleR[OF blin_matrix_vector_mult, symmetric] scaleR_vector_assoc ..

lemma norm_matrix_vec_mult_le_transpose:
  "\<parallel>x\<parallel> = 1 \<Longrightarrow> (\<parallel>A *v x\<parallel>) \<le> sqrt (\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x\<parallel>)" for A :: "real^'n^'n"
proof-
  assume "\<parallel>x\<parallel> = 1"
  have "(\<parallel>A *v x\<parallel>)\<^sup>2 = (A *v x) \<bullet> (A *v x)"
    using dot_square_norm[of "(A *v x)"] by simp
  also have "... = x \<bullet> (transpose A *v (A *v x))"
    using vec_mult_inner by blast
  also have "... \<le> (\<parallel>x\<parallel>) * (\<parallel>transpose A *v (A *v x)\<parallel>)"
    using norm_cauchy_schwarz by blast
  also have "... \<le> (\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x\<parallel>)^2"
    apply(subst matrix_vector_mul_assoc)
    using norm_matrix_le_mult_op_norm[of "transpose A ** A" x]
    by (simp add: \<open>\<parallel>x\<parallel> = 1\<close>)
  finally have "((\<parallel>A *v x\<parallel>))^2 \<le> (\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x\<parallel>)^2"
    by linarith
  thus "(\<parallel>A *v x\<parallel>) \<le> sqrt ((\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p)) * (\<parallel>x\<parallel>)"
    by (simp add: \<open>\<parallel>x\<parallel> = 1\<close> real_le_rsqrt)
qed

lemma op_norm_le_sum_column: "\<parallel>A\<parallel>\<^sub>o\<^sub>p \<le> (\<Sum>i\<in>UNIV. \<parallel>column i A\<parallel>)" for A :: "real^'n^'m"
proof(unfold op_norm_def, rule cSup_least[OF op_norm_set_proptys(3)], clarsimp)
  fix x :: "real^'n" assume x_def:"\<parallel>x\<parallel> = 1"
  hence x_hyp:"\<And>i. \<parallel>x $ i\<parallel> \<le> 1"
    by (simp add: norm_bound_component_le_cart)
  have "(\<parallel>A *v x\<parallel>) = \<parallel>(\<Sum>i\<in>UNIV. x $ i *s column i A)\<parallel>"
    by(subst matrix_mult_sum[of A], simp)
  also have "... \<le> (\<Sum>i\<in>UNIV. \<parallel>x $ i *s column i A\<parallel>)"
    by (simp add: sum_norm_le)
  also have "... = (\<Sum>i\<in>UNIV. (\<parallel>x $ i\<parallel>) * (\<parallel>column i A\<parallel>))"
    by (simp add: mult_norm_matrix_sgn_eq)
  also have "... \<le> (\<Sum>i\<in>UNIV. \<parallel>column i A\<parallel>)"
    using x_hyp by (simp add: mult_left_le_one_le sum_mono)
  finally show "\<parallel>A *v x\<parallel> \<le> (\<Sum>i\<in>UNIV. \<parallel>column i A\<parallel>)" .
qed

lemma op_norm_le_transpose: "\<parallel>A\<parallel>\<^sub>o\<^sub>p \<le> \<parallel>transpose A\<parallel>\<^sub>o\<^sub>p" for A :: "real^'n^'n"
proof-
  have obs:"\<forall>x. \<parallel>x\<parallel> = 1 \<longrightarrow> (\<parallel>A *v x\<parallel>) \<le> sqrt ((\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p)) * (\<parallel>x\<parallel>)"
    using norm_matrix_vec_mult_le_transpose by blast
  have "(\<parallel>A\<parallel>\<^sub>o\<^sub>p) \<le> sqrt ((\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p))"
    using obs apply(unfold op_norm_def)
    by (rule cSup_least[OF op_norm_set_proptys(3)]) clarsimp
  hence "((\<parallel>A\<parallel>\<^sub>o\<^sub>p))\<^sup>2 \<le> (\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p)"
    using power_mono[of "(\<parallel>A\<parallel>\<^sub>o\<^sub>p)" _ 2] op_norm_ge_0
    by (metis not_le real_less_lsqrt)
  also have "... \<le> (\<parallel>transpose A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>A\<parallel>\<^sub>o\<^sub>p)"
    using op_norm_matrix_matrix_mult_le by blast
  finally have "((\<parallel>A\<parallel>\<^sub>o\<^sub>p))\<^sup>2 \<le> (\<parallel>transpose A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>A\<parallel>\<^sub>o\<^sub>p)"
    by linarith
  thus "(\<parallel>A\<parallel>\<^sub>o\<^sub>p) \<le> (\<parallel>transpose A\<parallel>\<^sub>o\<^sub>p)"
    using sq_le_cancel[of "(\<parallel>A\<parallel>\<^sub>o\<^sub>p)"] op_norm_ge_0 by metis
qed

subsection\<open> Matrix maximum norm \<close>

abbreviation max_norm :: "real^'n^'m \<Rightarrow> real" ("(1\<parallel>_\<parallel>\<^sub>m\<^sub>a\<^sub>x)" [65] 61)
  where "\<parallel>A\<parallel>\<^sub>m\<^sub>a\<^sub>x \<equiv> Max (abs ` (entries A))"

lemma max_norm_def: "\<parallel>A\<parallel>\<^sub>m\<^sub>a\<^sub>x = Max {\<bar>A $ i $ j\<bar>|i j. i\<in>UNIV \<and> j\<in>UNIV}"
  by (simp add: image_def, rule arg_cong[of _ _ Max], blast)

lemma max_norm_set_proptys: "finite {\<bar>A $ i $ j\<bar> |i j. i \<in> UNIV \<and> j \<in> UNIV}" (is "finite ?X")
proof-
  have "\<And>i. finite {\<bar>A $ i $ j\<bar> | j. j \<in> UNIV}"
    using finite_Atleast_Atmost_nat by fastforce
  hence "finite (\<Union>i\<in>UNIV. {\<bar>A $ i $ j\<bar> | j. j \<in> UNIV})" (is "finite ?Y")
    using finite_class.finite_UNIV by blast
  also have "?X \<subseteq> ?Y"
    by auto
  ultimately show ?thesis
    using finite_subset by blast
qed

lemma max_norm_ge_0: "0 \<le> \<parallel>A\<parallel>\<^sub>m\<^sub>a\<^sub>x"
  unfolding max_norm_def
  apply(rule order.trans[OF abs_ge_zero[of "A $ _ $ _"] Max_ge])
  using max_norm_set_proptys by auto

lemma op_norm_le_max_norm:
  fixes A :: "real^('n::finite)^('m::finite)"
  shows "\<parallel>A\<parallel>\<^sub>o\<^sub>p \<le> real CARD('m) * real CARD('n) * (\<parallel>A\<parallel>\<^sub>m\<^sub>a\<^sub>x)"
  apply(rule onorm_le_matrix_component)
  unfolding max_norm_def by(rule Max_ge[OF max_norm_set_proptys]) force

lemma sqrt_Sup_power2_eq_Sup_abs:
  "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> sqrt (Sup {(f i)\<^sup>2 |i. i \<in> A}) = Sup {\<bar>f i\<bar> |i. i \<in> A}"
proof(rule sym)
  assume assms: "finite A" "A \<noteq> {}"
  then obtain i where i_def: "i \<in> A \<and> Sup {(f i)\<^sup>2|i. i \<in> A} = (f i)^2"
    using cSup_finite_ex[of "{(f i)\<^sup>2|i. i \<in> A}"] by auto
  hence lhs: "sqrt (Sup {(f i)\<^sup>2 |i. i \<in> A}) = \<bar>f i\<bar>"
    by simp
  have "finite {(f i)\<^sup>2|i. i \<in> A}"
    using assms by simp
  hence "\<forall>j\<in>A. (f j)\<^sup>2 \<le> (f i)\<^sup>2"
    using i_def cSup_upper[of _ "{(f i)\<^sup>2 |i. i \<in> A}"] by force
  hence "\<forall>j\<in>A. \<bar>f j\<bar> \<le> \<bar>f i\<bar>"
    using abs_le_square_iff by blast
  also have "\<bar>f i\<bar> \<in> {\<bar>f i\<bar> |i. i \<in> A}"
    using i_def by auto
  ultimately show "Sup {\<bar>f i\<bar> |i. i \<in> A} = sqrt (Sup {(f i)\<^sup>2 |i. i \<in> A})"
    using cSup_mem_eq[of "\<bar>f i\<bar>" "{\<bar>f i\<bar> |i. i \<in> A}"] lhs by auto
qed

lemma sqrt_Max_power2_eq_max_abs:
  "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> sqrt (Max {(f i)\<^sup>2|i. i \<in> A}) = Max {\<bar>f i\<bar> |i. i \<in> A}"
  apply(subst cSup_eq_Max[symmetric], simp_all)+
  using sqrt_Sup_power2_eq_Sup_abs .

lemma op_norm_diag_mat_eq: "\<parallel>diag_mat f\<parallel>\<^sub>o\<^sub>p = Max {\<bar>f i\<bar> |i. i \<in> UNIV}" (is "_ = Max ?A")
proof(unfold op_norm_def)
  have obs: "\<And>x i. (f i)\<^sup>2 * (x $ i)\<^sup>2 \<le> Max {(f i)\<^sup>2|i. i \<in> UNIV} * (x $ i)\<^sup>2"
    apply(rule mult_right_mono[OF _ zero_le_power2])
    using le_max_image_of_finite[of "\<lambda>i. (f i)^2"] by simp
  {fix r assume "r \<in> {\<parallel>diag_mat f *v x\<parallel> |x. \<parallel>x\<parallel> = 1}"
    then obtain x where x_def: "\<parallel>diag_mat f *v x\<parallel> = r \<and> \<parallel>x\<parallel> = 1"
      by blast
    hence "r\<^sup>2 = (\<Sum>i\<in>UNIV. (f i)\<^sup>2 * (x $ i)\<^sup>2)"
      unfolding norm_vec_def L2_set_def matrix_vector_mul_diag_mat
      apply (simp add: power_mult_distrib)
      by (metis (no_types, lifting) x_def norm_ge_zero real_sqrt_ge_0_iff real_sqrt_pow2)
    also have "... \<le> (Max {(f i)\<^sup>2|i. i \<in> UNIV}) * (\<Sum>i\<in>UNIV. (x $ i)\<^sup>2)"
      using obs[of _ x] by (simp add: sum_mono sum_distrib_left)
    also have "... = Max {(f i)\<^sup>2|i. i \<in> UNIV}"
      using x_def by (simp add: norm_vec_def L2_set_def)
    finally have "r \<le> sqrt (Max {(f i)\<^sup>2|i. i \<in> UNIV})"
      using x_def real_le_rsqrt by blast
    hence "r \<le> Max ?A"
      by (subst (asm) sqrt_Max_power2_eq_max_abs[of UNIV f], simp_all)}
  hence 1: "\<forall>x\<in>{\<parallel>diag_mat f *v x\<parallel> |x. \<parallel>x\<parallel> = 1}. x \<le> Max ?A"
    unfolding diag_mat_def by blast
  obtain i where i_def: "Max ?A = \<parallel>diag_mat f *v \<e> i\<parallel>"
    using cMax_finite_ex[of ?A] by force
  hence 2: "\<exists>x\<in>{\<parallel>diag_mat f *v x\<parallel> |x. \<parallel>x\<parallel> = 1}. Max ?A \<le> x"
    by (metis (mono_tags, lifting) abs_1 mem_Collect_eq norm_axis_eq order_refl real_norm_def)
  show "Sup {\<parallel>diag_mat f *v x\<parallel> |x. \<parallel>x\<parallel> = 1} = Max ?A"
    by (rule cSup_eq[OF 1 2])
qed

lemma op_max_norms_eq_at_diag: "\<parallel>diag_mat f\<parallel>\<^sub>o\<^sub>p = \<parallel>diag_mat f\<parallel>\<^sub>m\<^sub>a\<^sub>x"
proof(rule antisym)
  have "{\<bar>f i\<bar> |i. i \<in> UNIV} \<subseteq> {\<bar>diag_mat f $ i $ j\<bar> |i j. i \<in> UNIV \<and> j \<in> UNIV}"
    by (smt Collect_mono diag_mat_vec_nth_simps(1))
  thus "\<parallel>diag_mat f\<parallel>\<^sub>o\<^sub>p \<le> \<parallel>diag_mat f\<parallel>\<^sub>m\<^sub>a\<^sub>x"
    unfolding op_norm_diag_mat_eq max_norm_def
    by (rule Max.subset_imp) (blast, simp only: finite_image_of_finite2)
next
  have "Sup {\<bar>diag_mat f $ i $ j\<bar> |i j. i \<in> UNIV \<and> j \<in> UNIV} \<le> Sup {\<bar>f i\<bar> |i. i \<in> UNIV}"
    apply(rule cSup_least, blast, clarify, case_tac "i = j", simp)
    by (rule cSup_upper, blast, simp_all) (rule cSup_upper2, auto)
  thus "\<parallel>diag_mat f\<parallel>\<^sub>m\<^sub>a\<^sub>x \<le> \<parallel>diag_mat f\<parallel>\<^sub>o\<^sub>p"
    unfolding op_norm_diag_mat_eq max_norm_def
    apply (subst cSup_eq_Max[symmetric], simp only: finite_image_of_finite2, blast)
    by (subst cSup_eq_Max[symmetric], simp, blast)
qed

end


theory NatStrongInduct

imports Main

begin

\<comment> \<open>
  Transformation of our induction hypothesis into the form expected by less_induct.
\<close>
lemma suc_induct:
  assumes \<open>\<And>n. \<forall>m \<le> n. P m \<Longrightarrow> P (Suc n)\<close>
  and     \<open>P 0\<close>
  and     \<open>\<forall>m < n. P m\<close>
  shows   \<open>P n\<close>
proof (cases n)
  case 0
    thus ?thesis using assms(2) by simp
next
  case (Suc k)
    thus ?thesis using assms le_imp_less_Suc by blast
qed

\<comment> \<open>
 Another induction rule for Noetherian induction that is easier to use in some proofs
\<close>
lemma nat_strong_induct [case_names 0 Suc]:
  fixes P :: \<open>nat \<Rightarrow> bool\<close>
  assumes \<open>P 0\<close>
      and \<open>\<And>n. \<forall>m \<le> n. P m \<Longrightarrow> P (Suc n)\<close>
    shows \<open>P n\<close>
using suc_induct[of \<open>P\<close>] assms less_induct[of \<open>P\<close> \<open>n\<close>] by blast

end


(*  Title:       Matrix norms
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

section \<open> Matrix norms \<close>

text \<open> Here, we explore some properties about the operator and the maximum norms for matrices. \<close>

theory MTX_Norms
  imports MTX_Preliminaries

begin

subsection\<open> Matrix operator norm \<close>

abbreviation op_norm :: "('a::real_normed_algebra_1)^'n^'m \<Rightarrow> real" ("(1\<parallel>_\<parallel>\<^sub>o\<^sub>p)" [65] 61)
  where "\<parallel>A\<parallel>\<^sub>o\<^sub>p \<equiv> onorm (\<lambda>x. A *v x)"

lemma norm_matrix_bound:
  fixes A :: "('a::real_normed_algebra_1)^'n^'m"
  shows "\<parallel>x\<parallel> = 1 \<Longrightarrow> \<parallel>A *v x\<parallel> \<le> \<parallel>(\<chi> i j. \<parallel>A $ i $ j\<parallel>) *v 1\<parallel>"
proof-
  fix x :: "('a, 'n) vec" assume "\<parallel>x\<parallel> = 1"
  hence xi_le1:"\<And>i. \<parallel>x $ i\<parallel> \<le> 1"
    by (metis Finite_Cartesian_Product.norm_nth_le)
  {fix j::'m
    have "\<parallel>(\<Sum>i\<in>UNIV. A $ j $ i * x $ i)\<parallel> \<le> (\<Sum>i\<in>UNIV. \<parallel>A $ j $ i * x $ i\<parallel>)"
      using norm_sum by blast
    also have "... \<le> (\<Sum>i\<in>UNIV. (\<parallel>A $ j $ i\<parallel>) * (\<parallel>x $ i\<parallel>))"
      by (simp add: norm_mult_ineq sum_mono)
    also have "... \<le> (\<Sum>i\<in>UNIV. (\<parallel>A $ j $ i\<parallel>) * 1)"
      using xi_le1 by (simp add: sum_mono mult_left_le)
    finally have "\<parallel>(\<Sum>i\<in>UNIV. A $ j $ i * x $ i)\<parallel> \<le> (\<Sum>i\<in>UNIV. (\<parallel>A $ j $ i\<parallel>) * 1)" by simp}
  hence "\<And>j. \<parallel>(A *v x) $ j\<parallel> \<le> ((\<chi> i1 i2. \<parallel>A $ i1 $ i2\<parallel>) *v 1) $ j"
    unfolding matrix_vector_mult_def by simp
  hence "(\<Sum>j\<in>UNIV. (\<parallel>(A *v x) $ j\<parallel>)\<^sup>2) \<le> (\<Sum>j\<in>UNIV. (\<parallel>((\<chi> i1 i2. \<parallel>A $ i1 $ i2\<parallel>) *v 1) $ j\<parallel>)\<^sup>2)"
    by (metis (mono_tags, lifting) norm_ge_zero power2_abs power_mono real_norm_def sum_mono)
  thus "\<parallel>A *v x\<parallel> \<le> \<parallel>(\<chi> i j. \<parallel>A $ i $ j\<parallel>) *v 1\<parallel>"
    unfolding norm_vec_def L2_set_def by simp
qed

lemma onorm_set_proptys:
  fixes A :: "('a::real_normed_algebra_1)^'n^'m"
  shows "bounded (range (\<lambda>x. (\<parallel>A *v x\<parallel>) / (\<parallel>x\<parallel>)))"
    and "bdd_above (range (\<lambda>x. (\<parallel>A *v x\<parallel>) / (\<parallel>x\<parallel>)))"
    and "(range (\<lambda>x. (\<parallel>A *v x\<parallel>) / (\<parallel>x\<parallel>))) \<noteq> {}"
  unfolding bounded_def bdd_above_def image_def dist_real_def
    apply(rule_tac x=0 in exI)
  by (rule_tac x="\<parallel>(\<chi> i j. \<parallel>A $ i $ j\<parallel>) *v 1\<parallel>" in exI, clarsimp,
      subst mult_norm_matrix_sgn_eq[symmetric], clarsimp,
      rule_tac x="sgn _" in norm_matrix_bound, simp add: norm_sgn)+ force

lemma op_norm_set_proptys:
  fixes A :: "('a::real_normed_algebra_1)^'n^'m"
  shows "bounded {\<parallel>A *v x\<parallel> | x. \<parallel>x\<parallel> = 1}"
    and "bdd_above {\<parallel>A *v x\<parallel> | x. \<parallel>x\<parallel> = 1}"
    and "{\<parallel>A *v x\<parallel> | x. \<parallel>x\<parallel> = 1} \<noteq> {}"
  unfolding bounded_def bdd_above_def apply safe
    apply(rule_tac x=0 in exI, rule_tac x="\<parallel>(\<chi> i j. \<parallel>A $ i $ j\<parallel>) *v 1\<parallel>" in exI)
    apply(force simp: norm_matrix_bound dist_real_def)
   apply(rule_tac x="\<parallel>(\<chi> i j. \<parallel>A $ i $ j\<parallel>) *v 1\<parallel>" in exI, force simp: norm_matrix_bound)
  using ex_norm_eq_1 by blast

lemma op_norm_def: "\<parallel>A\<parallel>\<^sub>o\<^sub>p = Sup {\<parallel>A *v x\<parallel> | x. \<parallel>x\<parallel> = 1}"
  apply(rule antisym[OF onorm_le cSup_least[OF op_norm_set_proptys(3)]])
   apply(case_tac "x = 0", simp)
   apply(subst mult_norm_matrix_sgn_eq[symmetric], simp)
   apply(rule cSup_upper[OF _ op_norm_set_proptys(2)])
   apply(force simp: norm_sgn)
  unfolding onorm_def
  apply(rule cSup_upper[OF _ onorm_set_proptys(2)])
  by (simp add: image_def, clarsimp) (metis div_by_1)

lemma norm_matrix_le_op_norm: "\<parallel>x\<parallel> = 1 \<Longrightarrow> \<parallel>A *v x\<parallel> \<le> \<parallel>A\<parallel>\<^sub>o\<^sub>p"
  apply(unfold onorm_def, rule cSup_upper[OF _ onorm_set_proptys(2)])
  unfolding image_def by (clarsimp, rule_tac x=x in exI) simp

lemma op_norm_ge_0: "0 \<le> \<parallel>A\<parallel>\<^sub>o\<^sub>p"
  using ex_norm_eq_1 norm_ge_zero norm_matrix_le_op_norm basic_trans_rules(23) by blast

lemma norm_sgn_le_op_norm: "\<parallel>A *v sgn x\<parallel> \<le> \<parallel>A\<parallel>\<^sub>o\<^sub>p"
  by (cases "x=0", simp_all add: norm_sgn norm_matrix_le_op_norm op_norm_ge_0)

lemma norm_matrix_le_mult_op_norm: "\<parallel>A *v x\<parallel> \<le> (\<parallel>A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x\<parallel>)"
proof-
  have "\<parallel>A *v x\<parallel> = (\<parallel>A *v sgn x\<parallel>) * (\<parallel>x\<parallel>)"
    by(simp add: mult_norm_matrix_sgn_eq)
  also have "... \<le> (\<parallel>A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x\<parallel>)"
    using norm_sgn_le_op_norm[of A] by (simp add: mult_mono')
  finally show ?thesis by simp
qed

lemma blin_matrix_vector_mult: "bounded_linear ((*v) A)" for A :: "('a::real_normed_algebra_1)^'n^'m"
  by (unfold_locales) (auto intro: norm_matrix_le_mult_op_norm simp:
      mult.commute matrix_vector_right_distrib vector_scaleR_commute)

lemma op_norm_eq_0: "(\<parallel>A\<parallel>\<^sub>o\<^sub>p = 0) = (A = 0)" for A :: "('a::real_normed_field)^'n^'m"
  unfolding onorm_eq_0[OF blin_matrix_vector_mult] using matrix_axis_0[of 1 A] by fastforce

lemma op_norm0: "\<parallel>(0::('a::real_normed_field)^'n^'m)\<parallel>\<^sub>o\<^sub>p = 0"
  using op_norm_eq_0[of 0] by simp

lemma op_norm_triangle: "\<parallel>A + B\<parallel>\<^sub>o\<^sub>p \<le> (\<parallel>A\<parallel>\<^sub>o\<^sub>p) + (\<parallel>B\<parallel>\<^sub>o\<^sub>p)"
  using onorm_triangle[OF blin_matrix_vector_mult[of A] blin_matrix_vector_mult[of B]]
    matrix_vector_mult_add_rdistrib[symmetric, of A _ B] by simp

lemma op_norm_scaleR: "\<parallel>c *\<^sub>R A\<parallel>\<^sub>o\<^sub>p = \<bar>c\<bar> * (\<parallel>A\<parallel>\<^sub>o\<^sub>p)"
  unfolding onorm_scaleR[OF blin_matrix_vector_mult, symmetric] scaleR_vector_assoc ..

lemma norm_matrix_vec_mult_le_transpose:
  "\<parallel>x\<parallel> = 1 \<Longrightarrow> (\<parallel>A *v x\<parallel>) \<le> sqrt (\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x\<parallel>)" for A :: "real^'n^'n"
proof-
  assume "\<parallel>x\<parallel> = 1"
  have "(\<parallel>A *v x\<parallel>)\<^sup>2 = (A *v x) \<bullet> (A *v x)"
    using dot_square_norm[of "(A *v x)"] by simp
  also have "... = x \<bullet> (transpose A *v (A *v x))"
    using vec_mult_inner by blast
  also have "... \<le> (\<parallel>x\<parallel>) * (\<parallel>transpose A *v (A *v x)\<parallel>)"
    using norm_cauchy_schwarz by blast
  also have "... \<le> (\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x\<parallel>)^2"
    apply(subst matrix_vector_mul_assoc)
    using norm_matrix_le_mult_op_norm[of "transpose A ** A" x]
    by (simp add: \<open>\<parallel>x\<parallel> = 1\<close>)
  finally have "((\<parallel>A *v x\<parallel>))^2 \<le> (\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x\<parallel>)^2"
    by linarith
  thus "(\<parallel>A *v x\<parallel>) \<le> sqrt ((\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p)) * (\<parallel>x\<parallel>)"
    by (simp add: \<open>\<parallel>x\<parallel> = 1\<close> real_le_rsqrt)
qed

lemma op_norm_le_sum_column: "\<parallel>A\<parallel>\<^sub>o\<^sub>p \<le> (\<Sum>i\<in>UNIV. \<parallel>column i A\<parallel>)" for A :: "real^'n^'m"
proof(unfold op_norm_def, rule cSup_least[OF op_norm_set_proptys(3)], clarsimp)
  fix x :: "real^'n" assume x_def:"\<parallel>x\<parallel> = 1"
  hence x_hyp:"\<And>i. \<parallel>x $ i\<parallel> \<le> 1"
    by (simp add: norm_bound_component_le_cart)
  have "(\<parallel>A *v x\<parallel>) = \<parallel>(\<Sum>i\<in>UNIV. x $ i *s column i A)\<parallel>"
    by(subst matrix_mult_sum[of A], simp)
  also have "... \<le> (\<Sum>i\<in>UNIV. \<parallel>x $ i *s column i A\<parallel>)"
    by (simp add: sum_norm_le)
  also have "... = (\<Sum>i\<in>UNIV. (\<parallel>x $ i\<parallel>) * (\<parallel>column i A\<parallel>))"
    by (simp add: mult_norm_matrix_sgn_eq)
  also have "... \<le> (\<Sum>i\<in>UNIV. \<parallel>column i A\<parallel>)"
    using x_hyp by (simp add: mult_left_le_one_le sum_mono)
  finally show "\<parallel>A *v x\<parallel> \<le> (\<Sum>i\<in>UNIV. \<parallel>column i A\<parallel>)" .
qed

lemma op_norm_le_transpose: "\<parallel>A\<parallel>\<^sub>o\<^sub>p \<le> \<parallel>transpose A\<parallel>\<^sub>o\<^sub>p" for A :: "real^'n^'n"
proof-
  have obs:"\<forall>x. \<parallel>x\<parallel> = 1 \<longrightarrow> (\<parallel>A *v x\<parallel>) \<le> sqrt ((\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p)) * (\<parallel>x\<parallel>)"
    using norm_matrix_vec_mult_le_transpose by blast
  have "(\<parallel>A\<parallel>\<^sub>o\<^sub>p) \<le> sqrt ((\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p))"
    using obs apply(unfold op_norm_def)
    by (rule cSup_least[OF op_norm_set_proptys(3)]) clarsimp
  hence "((\<parallel>A\<parallel>\<^sub>o\<^sub>p))\<^sup>2 \<le> (\<parallel>transpose A ** A\<parallel>\<^sub>o\<^sub>p)"
    using power_mono[of "(\<parallel>A\<parallel>\<^sub>o\<^sub>p)" _ 2] op_norm_ge_0
    by (metis not_le real_less_lsqrt)
  also have "... \<le> (\<parallel>transpose A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>A\<parallel>\<^sub>o\<^sub>p)"
    using op_norm_matrix_matrix_mult_le by blast
  finally have "((\<parallel>A\<parallel>\<^sub>o\<^sub>p))\<^sup>2 \<le> (\<parallel>transpose A\<parallel>\<^sub>o\<^sub>p) * (\<parallel>A\<parallel>\<^sub>o\<^sub>p)"
    by linarith
  thus "(\<parallel>A\<parallel>\<^sub>o\<^sub>p) \<le> (\<parallel>transpose A\<parallel>\<^sub>o\<^sub>p)"
    using sq_le_cancel[of "(\<parallel>A\<parallel>\<^sub>o\<^sub>p)"] op_norm_ge_0 by metis
qed

subsection\<open> Matrix maximum norm \<close>

abbreviation max_norm :: "real^'n^'m \<Rightarrow> real" ("(1\<parallel>_\<parallel>\<^sub>m\<^sub>a\<^sub>x)" [65] 61)
  where "\<parallel>A\<parallel>\<^sub>m\<^sub>a\<^sub>x \<equiv> Max (abs ` (entries A))"

lemma max_norm_def: "\<parallel>A\<parallel>\<^sub>m\<^sub>a\<^sub>x = Max {\<bar>A $ i $ j\<bar>|i j. i\<in>UNIV \<and> j\<in>UNIV}"
  by (simp add: image_def, rule arg_cong[of _ _ Max], blast)

lemma max_norm_set_proptys: "finite {\<bar>A $ i $ j\<bar> |i j. i \<in> UNIV \<and> j \<in> UNIV}" (is "finite ?X")
proof-
  have "\<And>i. finite {\<bar>A $ i $ j\<bar> | j. j \<in> UNIV}"
    using finite_Atleast_Atmost_nat by fastforce
  hence "finite (\<Union>i\<in>UNIV. {\<bar>A $ i $ j\<bar> | j. j \<in> UNIV})" (is "finite ?Y")
    using finite_class.finite_UNIV by blast
  also have "?X \<subseteq> ?Y"
    by auto
  ultimately show ?thesis
    using finite_subset by blast
qed

lemma max_norm_ge_0: "0 \<le> \<parallel>A\<parallel>\<^sub>m\<^sub>a\<^sub>x"
  unfolding max_norm_def
  apply(rule order.trans[OF abs_ge_zero[of "A $ _ $ _"] Max_ge])
  using max_norm_set_proptys by auto

lemma op_norm_le_max_norm:
  fixes A :: "real^('n::finite)^('m::finite)"
  shows "\<parallel>A\<parallel>\<^sub>o\<^sub>p \<le> real CARD('m) * real CARD('n) * (\<parallel>A\<parallel>\<^sub>m\<^sub>a\<^sub>x)"
  apply(rule onorm_le_matrix_component)
  unfolding max_norm_def by(rule Max_ge[OF max_norm_set_proptys]) force

lemma sqrt_Sup_power2_eq_Sup_abs:
  "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> sqrt (Sup {(f i)\<^sup>2 |i. i \<in> A}) = Sup {\<bar>f i\<bar> |i. i \<in> A}"
proof(rule sym)
  assume assms: "finite A" "A \<noteq> {}"
  then obtain i where i_def: "i \<in> A \<and> Sup {(f i)\<^sup>2|i. i \<in> A} = (f i)^2"
    using cSup_finite_ex[of "{(f i)\<^sup>2|i. i \<in> A}"] by auto
  hence lhs: "sqrt (Sup {(f i)\<^sup>2 |i. i \<in> A}) = \<bar>f i\<bar>"
    by simp
  have "finite {(f i)\<^sup>2|i. i \<in> A}"
    using assms by simp
  hence "\<forall>j\<in>A. (f j)\<^sup>2 \<le> (f i)\<^sup>2"
    using i_def cSup_upper[of _ "{(f i)\<^sup>2 |i. i \<in> A}"] by force
  hence "\<forall>j\<in>A. \<bar>f j\<bar> \<le> \<bar>f i\<bar>"
    using abs_le_square_iff by blast
  also have "\<bar>f i\<bar> \<in> {\<bar>f i\<bar> |i. i \<in> A}"
    using i_def by auto
  ultimately show "Sup {\<bar>f i\<bar> |i. i \<in> A} = sqrt (Sup {(f i)\<^sup>2 |i. i \<in> A})"
    using cSup_mem_eq[of "\<bar>f i\<bar>" "{\<bar>f i\<bar> |i. i \<in> A}"] lhs by auto
qed

lemma sqrt_Max_power2_eq_max_abs:
  "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> sqrt (Max {(f i)\<^sup>2|i. i \<in> A}) = Max {\<bar>f i\<bar> |i. i \<in> A}"
  apply(subst cSup_eq_Max[symmetric], simp_all)+
  using sqrt_Sup_power2_eq_Sup_abs .

lemma op_norm_diag_mat_eq: "\<parallel>diag_mat f\<parallel>\<^sub>o\<^sub>p = Max {\<bar>f i\<bar> |i. i \<in> UNIV}" (is "_ = Max ?A")
proof(unfold op_norm_def)
  have obs: "\<And>x i. (f i)\<^sup>2 * (x $ i)\<^sup>2 \<le> Max {(f i)\<^sup>2|i. i \<in> UNIV} * (x $ i)\<^sup>2"
    apply(rule mult_right_mono[OF _ zero_le_power2])
    using le_max_image_of_finite[of "\<lambda>i. (f i)^2"] by simp
  {fix r assume "r \<in> {\<parallel>diag_mat f *v x\<parallel> |x. \<parallel>x\<parallel> = 1}"
    then obtain x where x_def: "\<parallel>diag_mat f *v x\<parallel> = r \<and> \<parallel>x\<parallel> = 1"
      by blast
    hence "r\<^sup>2 = (\<Sum>i\<in>UNIV. (f i)\<^sup>2 * (x $ i)\<^sup>2)"
      unfolding norm_vec_def L2_set_def matrix_vector_mul_diag_mat
      apply (simp add: power_mult_distrib)
      by (metis (no_types, lifting) x_def norm_ge_zero real_sqrt_ge_0_iff real_sqrt_pow2)
    also have "... \<le> (Max {(f i)\<^sup>2|i. i \<in> UNIV}) * (\<Sum>i\<in>UNIV. (x $ i)\<^sup>2)"
      using obs[of _ x] by (simp add: sum_mono sum_distrib_left)
    also have "... = Max {(f i)\<^sup>2|i. i \<in> UNIV}"
      using x_def by (simp add: norm_vec_def L2_set_def)
    finally have "r \<le> sqrt (Max {(f i)\<^sup>2|i. i \<in> UNIV})"
      using x_def real_le_rsqrt by blast
    hence "r \<le> Max ?A"
      by (subst (asm) sqrt_Max_power2_eq_max_abs[of UNIV f], simp_all)}
  hence 1: "\<forall>x\<in>{\<parallel>diag_mat f *v x\<parallel> |x. \<parallel>x\<parallel> = 1}. x \<le> Max ?A"
    unfolding diag_mat_def by blast
  obtain i where i_def: "Max ?A = \<parallel>diag_mat f *v \<e> i\<parallel>"
    using cMax_finite_ex[of ?A] by force
  hence 2: "\<exists>x\<in>{\<parallel>diag_mat f *v x\<parallel> |x. \<parallel>x\<parallel> = 1}. Max ?A \<le> x"
    by (metis (mono_tags, lifting) abs_1 mem_Collect_eq norm_axis_eq order_refl real_norm_def)
  show "Sup {\<parallel>diag_mat f *v x\<parallel> |x. \<parallel>x\<parallel> = 1} = Max ?A"
    by (rule cSup_eq[OF 1 2])
qed

lemma op_max_norms_eq_at_diag: "\<parallel>diag_mat f\<parallel>\<^sub>o\<^sub>p = \<parallel>diag_mat f\<parallel>\<^sub>m\<^sub>a\<^sub>x"
proof(rule antisym)
  have "{\<bar>f i\<bar> |i. i \<in> UNIV} \<subseteq> {\<bar>diag_mat f $ i $ j\<bar> |i j. i \<in> UNIV \<and> j \<in> UNIV}"
    by (smt Collect_mono diag_mat_vec_nth_simps(1))
  thus "\<parallel>diag_mat f\<parallel>\<^sub>o\<^sub>p \<le> \<parallel>diag_mat f\<parallel>\<^sub>m\<^sub>a\<^sub>x"
    unfolding op_norm_diag_mat_eq max_norm_def
    by (rule Max.subset_imp) (blast, simp only: finite_image_of_finite2)
next
  have "Sup {\<bar>diag_mat f $ i $ j\<bar> |i j. i \<in> UNIV \<and> j \<in> UNIV} \<le> Sup {\<bar>f i\<bar> |i. i \<in> UNIV}"
    apply(rule cSup_least, blast, clarify, case_tac "i = j", simp)
    by (rule cSup_upper, blast, simp_all) (rule cSup_upper2, auto)
  thus "\<parallel>diag_mat f\<parallel>\<^sub>m\<^sub>a\<^sub>x \<le> \<parallel>diag_mat f\<parallel>\<^sub>o\<^sub>p"
    unfolding op_norm_diag_mat_eq max_norm_def
    apply (subst cSup_eq_Max[symmetric], simp only: finite_image_of_finite2, blast)
    by (subst cSup_eq_Max[symmetric], simp, blast)
qed

end