theory IsarTutorial_Answer
imports Main
begin

lemma "Exer1-1_Answer_pattern_1": "Q \<Longrightarrow> (P \<longrightarrow> Q)"
proof (rule impI)
  assume q: "Q"
  show "Q" by (rule q)
qed

lemma "Exer1-1_Answer_pattern_2": "Q \<Longrightarrow> (P \<longrightarrow> Q)"
proof (rule impI) qed

lemma "Exer1-1_Answer_pattern_3": "Q \<Longrightarrow> (P \<longrightarrow> Q)"
proof (rule impI)
  assume q: "Q"
  from this show "Q" by assumption
qed

lemma "Exer1-2": "(P \<and> Q) \<and> R \<longrightarrow> Q"
proof (rule impI)
  assume pqr: "(P \<and> Q) \<and> R"
  from pqr show "Q"
  proof (rule conjE)
    assume pq: "P \<and> Q" and r: "R"
    from pq show "Q" by (rule conjunct2)
  qed
qed

lemma "Exer2-1": "P \<longrightarrow> (P \<longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q"
proof (rule impI)
  assume "P \<longrightarrow> (P \<longrightarrow> Q)" "P"
  then have "P \<longrightarrow> Q" by (rule mp)
  with `P` show "Q" by (rule rev_mp)
qed

lemma "Exer2-2": "P \<or> Q \<longrightarrow> R \<Longrightarrow> P \<Longrightarrow> R"
proof -
  assume "P"
  then have "P \<or> Q" by (rule disjI1)
  assume "P \<or> Q \<longrightarrow> R"
  with `P \<or> Q` show "R" by (rule rev_mp)
qed

lemma "Exer2-3": "(P \<longrightarrow> Q) \<longrightarrow> (\<not>Q \<longrightarrow> \<not>P)"
proof ((rule impI)+, rule notI)
  assume "P \<longrightarrow> Q" "P"
  then have "Q" by (rule mp)
  assume "\<not>Q"
  from this `Q` show "False" by (rule notE)
qed

lemma "Exer2-4":
  assumes "P \<or> Q" "\<not>P"
  shows "Q"
  using assms(1)
proof (rule disjE)
  assume "P"
  with assms(2) show "Q" by (rule notE)
next
  assume "Q"
  show "Q" by (rule `Q`)
qed

lemma "Exer2-5":
  assumes "(P \<or> Q) \<longrightarrow> R"
  shows "(P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)"
proof (rule conjI)
  show "P \<longrightarrow> R"
  proof (rule impI)
    assume "P"
    then have "P \<or> Q" by (rule disjI1)
    with assms(1) show "R" by (rule mp)
  qed
next
  show "Q \<longrightarrow> R"
  proof (rule impI)
    assume "Q"
    then have "P \<or> Q" by (rule disjI2)
    with assms(1) show "R" by (rule mp)
  qed
qed

lemma "Exer3-1":
  assumes "\<forall>x. P x" and "\<forall>x. P x \<longrightarrow> Q x"
  shows "\<forall>x. Q x"
proof (rule allI)
  fix x
  from assms(1) have 1: "P x" by (rule spec)
  from assms(2) have 2: "P x \<longrightarrow> Q x" by (rule spec)
  from 2 1 show "Q x" by (rule mp)
qed

lemma "Exer3-2":
  assumes "\<forall>x. (P x \<longrightarrow> (\<exists>y. Q y))"
  shows "(\<exists>x. P x) \<longrightarrow> (\<exists>x. Q x)"
proof (rule impI)
  assume "\<exists>x. P x"
  then obtain x where 1: "P x" by (rule exE)
  from assms(1) have 2: "P x \<longrightarrow> (\<exists>y. Q y)" by (rule spec)
  from 2 1 show "\<exists>x. Q x" by (rule mp)
qed

lemma "Exer3-3(don't use obtain)":
  assumes "\<exists>x. P x"
  shows "\<exists>x. (P x \<or> Q x)"
  using assms
proof (rule exE)
  fix x
  assume "P x"
  then have "P x \<or> Q x" by (rule disjI1)
  then show "\<exists>x. (P x \<or> Q x)" by (rule exI)
qed

lemma "Exer3-4": "x \<in> \<Union>C \<Longrightarrow> \<exists>A\<in>C. x \<in> A"
(* hint *)
thm UnionE (* ?A \<in> \<Union> ?C \<Longrightarrow> (\<And>X. ?A \<in> X \<Longrightarrow> X \<in> ?C \<Longrightarrow> ?R) \<Longrightarrow> ?R *)
thm bexI   (* ?P ?x \<Longrightarrow> ?x \<in> ?A \<Longrightarrow> \<exists>x\<in>?A. ?P x *)
proof -
  assume "x \<in> \<Union>C"
  then obtain "A" where "x \<in> A" and "A \<in> C"  by (rule UnionE)
  then show "\<exists>A\<in>C. x \<in> A" by (rule bexI)
qed

lemma "Exer4-1(use moreover, ultimately)": "A \<and> B \<Longrightarrow> B \<and> A"
proof -
  assume a: "A \<and> B"
  then have "B" by (rule conjunct2)
  moreover
  from a have "A" by (rule conjunct1)
  ultimately show "B \<and> A" by (rule conjI)
qed

lemma "Exer4-2(use moreover, ultimately)":
  assumes "(P \<longrightarrow> Q) \<and> (\<not>P \<longrightarrow> Q)"
  shows "Q"
  using assms
proof(rule conjE)
  assume 1: "P \<longrightarrow> Q" and 2: "\<not>P \<longrightarrow> Q"
  {
    assume "P"
    with 1 have "Q" by (rule mp)
  }
  moreover
  {
    assume "\<not>P"
    with 2 have "Q" by (rule mp)
  }
  ultimately show "Q" by (cases "P")
qed

lemma "Exer4-3": "(P \<longrightarrow> Q) \<and> (\<not>P \<longrightarrow> Q) \<Longrightarrow> Q"
proof (cases "P")
  case True
  assume "(P \<longrightarrow> Q) \<and> (\<not>P \<longrightarrow> Q)"
  then show ?thesis
  proof (rule conjE)
    assume "P \<longrightarrow> Q"
    with True show ?thesis by (rule rev_mp)
  qed
next
  case False
  assume "(P \<longrightarrow> Q) \<and> (\<not>P \<longrightarrow> Q)"
  then show ?thesis
  proof (rule conjE)
    assume "\<not>P \<longrightarrow> Q"
    with False show ?thesis by (rule rev_mp)
  qed
qed

lemma "Exer4-4": "\<forall>x. P \<or> Q x \<Longrightarrow> P \<or> (\<forall>x. Q x)"
proof (cases "P")
  case True
  then show ?thesis by (rule disjI1)
next
  case False
  assume 1: "\<forall>x. P \<or> Q x"
  show ?thesis
  proof (rule disjI2)
    show "\<forall>x. Q x"
    proof (rule allI)
      fix x
      from 1 have 2:"P \<or> Q x" by (rule spec)
      from 2 show "Q x"
      proof (rule disjE)
        assume "P"
        with False show ?thesis by (rule notE)
      qed
    qed
  qed
qed

lemma "Exer4-5": "if y \<le> x then z = x else z = y \<Longrightarrow> z = x \<or> z = y"
(* hint *)
thm if_P      (* ?P \<Longrightarrow> (if ?P then ?x else ?y) = ?x *)
thm if_not_P  (* \<not> ?P \<Longrightarrow> (if ?P then ?x else ?y) = ?y *)
proof (cases "y \<le> x")
  case True
  assume a: "if y \<le> x then z = x else z = y"
  show ?thesis
  proof (rule disjI1)
    from True have 1: "(if y \<le> x then z = x else z = y) = (z = x)" by (rule if_P)
    from a show "z = x" by (subst (asm) 1)
  qed
next
  case False
  assume a: "if y \<le> x then z = x else z = y"
  show ?thesis
  proof (rule disjI2)
    from False have 1: "(if y \<le> x then z = x else z = y) = (z = y)" by (rule if_not_P)
    from a show "z = y" by (subst (asm) 1)
  qed
qed

primrec add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add m 0 = m" |
"add m (Suc n) = add (Suc m) n"

lemma "Exer8-1": "\<forall>m. add m n = m + n"
(* hint *)
thm add.simps(1) (* add ?m 0 = ?m *)
thm add.simps(2) (* add ?m (Suc ?n) = add (Suc ?m) ?n *)
thm add_0_right  (* ?a + 0 = ?a *)
thm add_Suc_shift (* Suc ?m + ?n = ?m + Suc ?n *)
proof (induction n)
  case 0
  then show ?case
  proof (rule allI)
    fix m
    show "add m 0 = m + 0"
      by (subst add.simps(1), subst add_0_right, rule refl)
  qed
next
  case (Suc n)
  show ?case
  proof (rule allI)
    fix m
    have "add m (Suc n) = add (Suc m) n" by (rule add.simps(2))
    also have "... = (Suc m) + n" by (subst Suc) (rule refl)
    also have "... = m + Suc n" by (rule add_Suc_shift)
    finally show "add m (Suc n) = m + Suc n" .
  qed
qed


(*  Title:      Sort.thy
    Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)

section \<open>Verification of Heap Sort\<close>

theory Heap
imports RemoveMax
begin

subsection \<open>Defining tree and properties of heap\<close>

datatype 'a Tree = "E" | "T" 'a "'a Tree" "'a Tree"

text\<open>With {\em E} is represented empty tree and with {\em T\ \ \ 'a\ \ \ 'a
  Tree\ \ \ 'a Tree} is represented a node whose root element is of
type {\em 'a} and its left and right branch is also a tree of
type {\em 'a}.\<close>

primrec size :: "'a Tree \<Rightarrow> nat" where
  "size E = 0"
| "size (T v l r) = 1 + size l + size r"

text\<open>Definition of the function that makes a multiset from the given tree:\<close>

primrec multiset where
  "multiset E = {#}"
| "multiset (T v l r) = multiset l + {#v#} + multiset r"

primrec val where
 "val (T v _ _) = v"

text\<open>Definition of the function that has the value {\em True} if the tree is
heap, otherwise it is {\em False}:\<close>

fun is_heap :: "'a::linorder Tree \<Rightarrow> bool" where
  "is_heap E = True"
| "is_heap (T v E E) = True"
| "is_heap (T v E r) = (v \<ge> val r \<and> is_heap r)"
| "is_heap (T v l E) = (v \<ge> val l \<and> is_heap l)"
| "is_heap (T v l r) = (v \<ge> val r \<and> is_heap r \<and> v \<ge> val l \<and> is_heap l)"

lemma heap_top_geq:
  assumes "a \<in># multiset t" "is_heap t"
  shows "val t \<ge> a"
using assms
by (induct t rule: is_heap.induct)  (auto split: if_split_asm)

lemma heap_top_max:
  assumes "t \<noteq> E" "is_heap t"
  shows "val t = Max_mset (multiset t)"
proof (rule Max_eqI[symmetric])
  fix y
  assume "y \<in> set_mset (multiset t)"
  thus "y \<le> val t"
    using heap_top_geq [of y t] \<open>is_heap t\<close>
    by simp
next
  show "val t \<in> set_mset (multiset t)"
    using \<open>t \<noteq> E\<close>
    by (cases t) auto
qed simp

text\<open>The next step is to define function {\em remove\_max}, but the
question is weather implementation of {\em remove\_max} depends on
implementation of the functions {\em is\_heap} and {\em multiset}. The
answer is negative. This suggests that another step of refinement
could be added before definition of function {\em
  remove\_max}. Additionally, there are other reasons why this should
be done, for example, function {\em remove\_max} could be implemented
in functional or in imperative manner.
\<close>

locale Heap =  Collection empty is_empty of_list  multiset for
  empty :: "'b" and
  is_empty :: "'b \<Rightarrow> bool" and
  of_list :: "'a::linorder list \<Rightarrow> 'b" and
  multiset :: "'b \<Rightarrow> 'a::linorder multiset" +
  fixes as_tree :: "'b \<Rightarrow> 'a::linorder Tree"
  \<comment> \<open>This function is not very important, but it is needed in order to avoide problems with types and to detect that observed object is a tree.\<close>
  fixes remove_max :: "'b \<Rightarrow> 'a \<times> 'b"
  assumes multiset: "multiset l = Heap.multiset (as_tree l)"
  assumes is_heap_of_list: "is_heap (as_tree (of_list i))"
  assumes as_tree_empty: "as_tree t = E \<longleftrightarrow> is_empty t"
  assumes remove_max_multiset':
  "\<lbrakk>\<not> is_empty l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow> add_mset m (multiset l') = multiset l"
  assumes remove_max_is_heap:
  "\<lbrakk>\<not> is_empty l; is_heap (as_tree l); (m, l') = remove_max l\<rbrakk> \<Longrightarrow>
  is_heap (as_tree l')"
  assumes remove_max_val:
  "\<lbrakk> \<not> is_empty t; (m, t') = remove_max t\<rbrakk> \<Longrightarrow> m = val (as_tree t)"

text\<open>It is very easy to prove that locale {\em Heap} is sublocale of locale {\em RemoveMax}\<close>

sublocale Heap <
  RemoveMax empty is_empty of_list multiset remove_max "\<lambda> t. is_heap (as_tree t)"
proof
  fix x
  show "is_heap (as_tree (of_list x))"
    by (rule is_heap_of_list)
next
  fix l m l'
  assume "\<not> is_empty l" "(m, l') = remove_max l"
  thus "add_mset m (multiset l') = multiset l"
    by (rule remove_max_multiset')
next
  fix l m l'
  assume "\<not> is_empty l" "is_heap (as_tree l)" "(m, l') = remove_max l"
  thus "is_heap (as_tree l')"
    by (rule remove_max_is_heap)
next
  fix l m l'
  assume "\<not> is_empty l" "is_heap (as_tree l)" "(m, l') = remove_max l"
  thus "m = Max (set l)"
    unfolding set_def
    using heap_top_max[of "as_tree l"] remove_max_val[of l m l']
    using multiset is_empty_inj as_tree_empty
    by auto
qed

primrec in_tree where
  "in_tree v E = False"
| "in_tree v (T v' l r) \<longleftrightarrow> v = v' \<or> in_tree v l \<or> in_tree v r"

lemma is_heap_max:
  assumes "in_tree v t" "is_heap t"
  shows "val t \<ge> v"
using assms
apply (induct t rule:is_heap.induct)
by auto

end


theory Isar imports Main begin

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -
  have "\<exists> a. {x. x \<notin> f x} = f a" using s
    by (auto simp: surj_def)
  thus "False" by blast
qed

lemma
  fixes a b :: int
  assumes "b dvd (a+b)"
  shows "b dvd a"
proof -
  have "\<exists> k'. a = b * k'" if asm: "a+b = b*k" for k
  proof
    show "a = b*(k-1)" using asm by (simp add: algebra_simps)
  qed
  then show ?thesis using assms by (auto simp add: dvd_def)
qed

(* A typical proof by case analysis on the form of xs: *)
lemma "length (tl xs) = length xs - 1"
proof (cases xs)
  assume "xs = []"
  thus ?thesis by simp
next
  fix y ys assume "xs = y # ys"
  thus ?thesis by simp
qed

(* Alternative: *)
lemma "length (tl xs) = length xs - 1"
proof (cases xs)
  case Nil
  thus ?thesis by simp
next
  case (Cons y ys)
  thus ?thesis by simp
qed

lemma "\<Sigma> {0..n :: nat} = n * (n+1) div 2"
proof (induction n)
  case 0
  show ?case by simp
next
  case (Suc n)
  thus ?case by simp
qed

end


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

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

datatype Nat = Z | S "Nat"

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

fun take :: "Nat => 'a list => 'a list" where
"take (Z) z = nil2"
| "take (S z2) (nil2) = nil2"
| "take (S z2) (cons2 x2 x3) = cons2 x2 (take z2 x3)"

fun rev :: "'a list => 'a list" where
"rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

fun len :: "'a list => Nat" where
"len (nil2) = Z"
| "len (cons2 z xs) = S (len xs)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) z = z"
| "drop (S z2) (nil2) = nil2"
| "drop (S z2) (cons2 x2 x3) = drop z2 x3"

fun t2 :: "Nat => Nat => Nat" where
"t2 (Z) z = Z"
| "t2 (S z2) (Z) = S z2"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :
  "((rev (drop i xs)) = (take (t2 (len xs) i) (rev xs)))"
  oops

end


section \<open>Lexicographic orderings\<close>

theory Lexord
  imports Main
begin

subsection \<open>The preorder case\<close>

locale lex_preordering = preordering
begin

inductive lex_less :: \<open>'a list \<Rightarrow> 'a list \<Rightarrow> bool\<close>  (infix \<open>[\<^bold><]\<close> 50)
where
  Nil: \<open>[] [\<^bold><] y # ys\<close>
| Cons: \<open>x \<^bold>< y \<Longrightarrow> x # xs [\<^bold><] y # ys\<close>
| Cons_eq: \<open>x \<^bold>\<le> y \<Longrightarrow> y \<^bold>\<le> x \<Longrightarrow> xs [\<^bold><] ys \<Longrightarrow> x # xs [\<^bold><] y # ys\<close>

inductive lex_less_eq :: \<open>'a list \<Rightarrow> 'a list \<Rightarrow> bool\<close>  (infix \<open>[\<^bold>\<le>]\<close> 50)
where
  Nil: \<open>[] [\<^bold>\<le>] ys\<close>
| Cons: \<open>x \<^bold>< y \<Longrightarrow> x # xs [\<^bold>\<le>] y # ys\<close>
| Cons_eq: \<open>x \<^bold>\<le> y \<Longrightarrow> y \<^bold>\<le> x \<Longrightarrow> xs [\<^bold>\<le>] ys \<Longrightarrow> x # xs [\<^bold>\<le>] y # ys\<close>

lemma lex_less_simps [simp]:
  \<open>[] [\<^bold><] y # ys\<close>
  \<open>\<not> xs [\<^bold><] []\<close>
  \<open>x # xs [\<^bold><] y # ys \<longleftrightarrow> x \<^bold>< y \<or> x \<^bold>\<le> y \<and> y \<^bold>\<le> x \<and> xs [\<^bold><] ys\<close>
  by (auto intro: lex_less.intros elim: lex_less.cases)

lemma lex_less_eq_simps [simp]:
  \<open>[] [\<^bold>\<le>] ys\<close>
  \<open>\<not> x # xs [\<^bold>\<le>] []\<close>
  \<open>x # xs [\<^bold>\<le>] y # ys \<longleftrightarrow> x \<^bold>< y \<or> x \<^bold>\<le> y \<and> y \<^bold>\<le> x \<and> xs [\<^bold>\<le>] ys\<close>
  by (auto intro: lex_less_eq.intros elim: lex_less_eq.cases)

lemma lex_less_code [code]:
  \<open>[] [\<^bold><] y # ys \<longleftrightarrow> True\<close>
  \<open>xs [\<^bold><] [] \<longleftrightarrow> False\<close>
  \<open>x # xs [\<^bold><] y # ys \<longleftrightarrow> x \<^bold>< y \<or> x \<^bold>\<le> y \<and> y \<^bold>\<le> x \<and> xs [\<^bold><] ys\<close>
  by simp_all

lemma lex_less_eq_code [code]:
  \<open>[] [\<^bold>\<le>] ys \<longleftrightarrow> True\<close>
  \<open>x # xs [\<^bold>\<le>] [] \<longleftrightarrow> False\<close>
  \<open>x # xs [\<^bold>\<le>] y # ys \<longleftrightarrow> x \<^bold>< y \<or> x \<^bold>\<le> y \<and> y \<^bold>\<le> x \<and> xs [\<^bold>\<le>] ys\<close>
  by simp_all

lemma preordering:
  \<open>preordering ([\<^bold>\<le>]) ([\<^bold><])\<close>
proof
  fix xs ys zs
  show \<open>xs [\<^bold>\<le>] xs\<close>
    by (induction xs) (simp_all add: refl)
  show \<open>xs [\<^bold>\<le>] zs\<close> if \<open>xs [\<^bold>\<le>] ys\<close> \<open>ys [\<^bold>\<le>] zs\<close>
  using that proof (induction arbitrary: zs)
    case (Nil ys)
    then show ?case by simp
  next
    case (Cons x y xs ys)
    then show ?case
      by (cases zs) (auto dest: strict_trans strict_trans2)
  next
    case (Cons_eq x y xs ys)
    then show ?case
      by (cases zs) (auto dest: strict_trans1 intro: trans)
  qed
  show \<open>xs [\<^bold><] ys \<longleftrightarrow> xs [\<^bold>\<le>] ys \<and> \<not> ys [\<^bold>\<le>] xs\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
  proof
    assume ?P
    then have \<open>xs [\<^bold>\<le>] ys\<close>
      by induction simp_all
    moreover have \<open>\<not> ys [\<^bold>\<le>] xs\<close>
      using \<open>?P\<close>
      by induction (simp_all, simp_all add: strict_iff_not asym)
    ultimately show ?Q ..
  next
    assume ?Q
    then have \<open>xs [\<^bold>\<le>] ys\<close> \<open>\<not> ys [\<^bold>\<le>] xs\<close>
      by auto
    then show ?P
    proof induction
      case (Nil ys)
      then show ?case
        by (cases ys) simp_all
    next
      case (Cons x y xs ys)
      then show ?case
        by simp
    next
      case (Cons_eq x y xs ys)
      then show ?case
        by simp
    qed
  qed
qed

interpretation lex: preordering \<open>([\<^bold>\<le>])\<close> \<open>([\<^bold><])\<close>
  by (fact preordering)

end

subsection \<open>The order case\<close>

locale lex_ordering = lex_preordering + ordering
begin

interpretation lex: preordering \<open>([\<^bold>\<le>])\<close> \<open>([\<^bold><])\<close>
  by (fact preordering)

lemma less_lex_Cons_iff [simp]:
  \<open>x # xs [\<^bold><] y # ys \<longleftrightarrow> x \<^bold>< y \<or> x = y \<and> xs [\<^bold><] ys\<close>
  by (auto intro: refl antisym)

lemma less_eq_lex_Cons_iff [simp]:
  \<open>x # xs [\<^bold>\<le>] y # ys \<longleftrightarrow> x \<^bold>< y \<or> x = y \<and> xs [\<^bold>\<le>] ys\<close>
  by (auto intro: refl antisym)

lemma ordering:
  \<open>ordering ([\<^bold>\<le>]) ([\<^bold><])\<close>
proof
  fix xs ys
  show *: \<open>xs = ys\<close> if \<open>xs [\<^bold>\<le>] ys\<close> \<open>ys [\<^bold>\<le>] xs\<close>
  using that proof induction
  case (Nil ys)
    then show ?case by (cases ys) simp
  next
    case (Cons x y xs ys)
    then show ?case by (auto dest: asym intro: antisym)
      (simp add: strict_iff_not)
  next
    case (Cons_eq x y xs ys)
    then show ?case by (auto intro: antisym)
      (simp add: strict_iff_not)
  qed
  show \<open>xs [\<^bold><] ys \<longleftrightarrow> xs [\<^bold>\<le>] ys \<and> xs \<noteq> ys\<close>
    by (auto simp add: lex.strict_iff_not dest: *)
qed

interpretation lex: ordering \<open>([\<^bold>\<le>])\<close> \<open>([\<^bold><])\<close>
  by (fact ordering)

end

subsection \<open>Canonical instance\<close>

instantiation list :: (preorder) preorder
begin

global_interpretation lex: lex_preordering \<open>(\<le>) :: 'a::preorder \<Rightarrow> 'a \<Rightarrow> bool\<close> \<open>(<) :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>
  defines less_eq_list = lex.lex_less_eq
    and less_list = lex.lex_less ..

instance
  by (rule class.preorder.of_class.intro, rule preordering_preorderI, fact lex.preordering)

end

global_interpretation lex: lex_ordering \<open>(\<le>) :: 'a::order \<Rightarrow> 'a \<Rightarrow> bool\<close> \<open>(<) :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>
  rewrites \<open>lex_preordering.lex_less_eq (\<le>) (<) = ((\<le>) :: 'a list \<Rightarrow> 'a list \<Rightarrow> bool)\<close>
    and \<open>lex_preordering.lex_less (\<le>) (<) = ((<) :: 'a list \<Rightarrow> 'a list \<Rightarrow> bool)\<close>
proof -
  interpret lex_ordering \<open>(\<le>) :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close> \<open>(<) :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close> ..
  show \<open>lex_ordering ((\<le>)  :: 'a \<Rightarrow> 'a \<Rightarrow> bool) (<)\<close>
    by (fact lex_ordering_axioms)
  show \<open>lex_preordering.lex_less_eq (\<le>) (<) = (\<le>)\<close>
    by (simp add: less_eq_list_def)
  show \<open>lex_preordering.lex_less (\<le>) (<) = (<)\<close>
    by (simp add: less_list_def)
qed

instance list :: (order) order
  by (rule class.order.of_class.intro, rule ordering_orderI, fact lex.ordering)

export_code \<open>(\<le>) :: _ list \<Rightarrow> _ list \<Rightarrow> bool\<close> \<open>(<) :: _ list \<Rightarrow> _ list \<Rightarrow> bool\<close> in Haskell

subsection \<open>Non-canonical instance\<close>

context comm_monoid_mult
begin

definition dvd_strict :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close>
  where \<open>dvd_strict a b \<longleftrightarrow> a dvd b \<and> \<not> b dvd a\<close>

end

global_interpretation dvd: lex_preordering \<open>(dvd) :: 'a::comm_monoid_mult \<Rightarrow> 'a \<Rightarrow> bool\<close> dvd_strict
  defines lex_dvd = dvd.lex_less_eq
    and lex_dvd_strict = dvd.lex_less
  by unfold_locales (auto simp add: dvd_strict_def)

global_interpretation lex_dvd: preordering lex_dvd lex_dvd_strict
  by (fact dvd.preordering)

definition \<open>example = lex_dvd [(4::int), - 7, 8] [- 8, 13, 5]\<close>

export_code example in Haskell

value example

end


(*  Title:      HOL/Analysis/Inner_Product.thy
    Author:     Brian Huffman
*)

section \<open>Inner Product Spaces and Gradient Derivative\<close>

theory Inner_Product
imports Complex_Main
begin

subsection \<open>Real inner product spaces\<close>

text \<open>
  Temporarily relax type constraints for \<^term>\<open>open\<close>, \<^term>\<open>uniformity\<close>,
  \<^term>\<open>dist\<close>, and \<^term>\<open>norm\<close>.
\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>open\<close>, SOME \<^typ>\<open>'a::open set \<Rightarrow> bool\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>dist\<close>, SOME \<^typ>\<open>'a::dist \<Rightarrow> 'a \<Rightarrow> real\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>uniformity\<close>, SOME \<^typ>\<open>('a::uniformity \<times> 'a) filter\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>norm\<close>, SOME \<^typ>\<open>'a::norm \<Rightarrow> real\<close>)\<close>

class real_inner = real_vector + sgn_div_norm + dist_norm + uniformity_dist + open_uniformity +
  fixes inner :: "'a \<Rightarrow> 'a \<Rightarrow> real"
  assumes inner_commute: "inner x y = inner y x"
  and inner_add_left: "inner (x + y) z = inner x z + inner y z"
  and inner_scaleR_left [simp]: "inner (scaleR r x) y = r * (inner x y)"
  and inner_ge_zero [simp]: "0 \<le> inner x x"
  and inner_eq_zero_iff [simp]: "inner x x = 0 \<longleftrightarrow> x = 0"
  and norm_eq_sqrt_inner: "norm x = sqrt (inner x x)"
begin

lemma inner_zero_left [simp]: "inner 0 x = 0"
  using inner_add_left [of 0 0 x] by simp

lemma inner_minus_left [simp]: "inner (- x) y = - inner x y"
  using inner_add_left [of x "- x" y] by simp

lemma inner_diff_left: "inner (x - y) z = inner x z - inner y z"
  using inner_add_left [of x "- y" z] by simp

lemma inner_sum_left: "inner (\<Sum>x\<in>A. f x) y = (\<Sum>x\<in>A. inner (f x) y)"
  by (cases "finite A", induct set: finite, simp_all add: inner_add_left)

lemma all_zero_iff [simp]: "(\<forall>u. inner x u = 0) \<longleftrightarrow> (x = 0)"
  by auto (use inner_eq_zero_iff in blast)

text \<open>Transfer distributivity rules to right argument.\<close>

lemma inner_add_right: "inner x (y + z) = inner x y + inner x z"
  using inner_add_left [of y z x] by (simp only: inner_commute)

lemma inner_scaleR_right [simp]: "inner x (scaleR r y) = r * (inner x y)"
  using inner_scaleR_left [of r y x] by (simp only: inner_commute)

lemma inner_zero_right [simp]: "inner x 0 = 0"
  using inner_zero_left [of x] by (simp only: inner_commute)

lemma inner_minus_right [simp]: "inner x (- y) = - inner x y"
  using inner_minus_left [of y x] by (simp only: inner_commute)

lemma inner_diff_right: "inner x (y - z) = inner x y - inner x z"
  using inner_diff_left [of y z x] by (simp only: inner_commute)

lemma inner_sum_right: "inner x (\<Sum>y\<in>A. f y) = (\<Sum>y\<in>A. inner x (f y))"
  using inner_sum_left [of f A x] by (simp only: inner_commute)

lemmas inner_add [algebra_simps] = inner_add_left inner_add_right
lemmas inner_diff [algebra_simps]  = inner_diff_left inner_diff_right
lemmas inner_scaleR = inner_scaleR_left inner_scaleR_right

text \<open>Legacy theorem names\<close>
lemmas inner_left_distrib = inner_add_left
lemmas inner_right_distrib = inner_add_right
lemmas inner_distrib = inner_left_distrib inner_right_distrib

lemma inner_gt_zero_iff [simp]: "0 < inner x x \<longleftrightarrow> x \<noteq> 0"
  by (simp add: order_less_le)

lemma power2_norm_eq_inner: "(norm x)\<^sup>2 = inner x x"
  by (simp add: norm_eq_sqrt_inner)

text \<open>Identities involving real multiplication and division.\<close>

lemma inner_mult_left: "inner (of_real m * a) b = m * (inner a b)"
  by (metis real_inner_class.inner_scaleR_left scaleR_conv_of_real)

lemma inner_mult_right: "inner a (of_real m * b) = m * (inner a b)"
  by (metis real_inner_class.inner_scaleR_right scaleR_conv_of_real)

lemma inner_mult_left': "inner (a * of_real m) b = m * (inner a b)"
  by (simp add: of_real_def)

lemma inner_mult_right': "inner a (b * of_real m) = (inner a b) * m"
  by (simp add: of_real_def real_inner_class.inner_scaleR_right)

lemma Cauchy_Schwarz_ineq2:
  "\<bar>inner x y\<bar> \<le> norm x * norm y"
proof (rule power2_le_imp_le)
  have "(inner x y)\<^sup>2 \<le> inner x x * inner y y"
    using Cauchy_Schwarz_ineq .
  thus "\<bar>inner x y\<bar>\<^sup>2 \<le> (norm x * norm y)\<^sup>2"
    by (simp add: power_mult_distrib power2_norm_eq_inner)
  show "0 \<le> norm x * norm y"
    unfolding norm_eq_sqrt_inner
    by (intro mult_nonneg_nonneg real_sqrt_ge_zero inner_ge_zero)
qed

lemma norm_cauchy_schwarz: "inner x y \<le> norm x * norm y"
  using Cauchy_Schwarz_ineq2 [of x y] by auto

subclass real_normed_vector
proof
  fix a :: real and x y :: 'a
  show "norm x = 0 \<longleftrightarrow> x = 0"
    unfolding norm_eq_sqrt_inner by simp
  show "norm (x + y) \<le> norm x + norm y"
    proof (rule power2_le_imp_le)
      have "inner x y \<le> norm x * norm y"
        by (rule norm_cauchy_schwarz)
      thus "(norm (x + y))\<^sup>2 \<le> (norm x + norm y)\<^sup>2"
        unfolding power2_sum power2_norm_eq_inner
        by (simp add: inner_add inner_commute)
      show "0 \<le> norm x + norm y"
        unfolding norm_eq_sqrt_inner by simp
    qed
  have "sqrt (a\<^sup>2 * inner x x) = \<bar>a\<bar> * sqrt (inner x x)"
    by (simp add: real_sqrt_mult)
  then show "norm (a *\<^sub>R x) = \<bar>a\<bar> * norm x"
    unfolding norm_eq_sqrt_inner
    by (simp add: power2_eq_square mult.assoc)
qed

end

lemma square_bound_lemma:
  fixes x :: real
  shows "x < (1 + x) * (1 + x)"
proof -
  have "(x + 1/2)\<^sup>2 + 3/4 > 0"
    using zero_le_power2[of "x+1/2"] by arith
  then show ?thesis
    by (simp add: field_simps power2_eq_square)
qed

lemma square_continuous:
  fixes e :: real
  shows "e > 0 \<Longrightarrow> \<exists>d. 0 < d \<and> (\<forall>y. \<bar>y - x\<bar> < d \<longrightarrow> \<bar>y * y - x * x\<bar> < e)"
  using isCont_power[OF continuous_ident, of x, unfolded isCont_def LIM_eq, rule_format, of e 2]
  by (force simp add: power2_eq_square)

lemma norm_le: "norm x \<le> norm y \<longleftrightarrow> inner x x \<le> inner y y"
  by (simp add: norm_eq_sqrt_inner)

lemma norm_lt: "norm x < norm y \<longleftrightarrow> inner x x < inner y y"
  by (simp add: norm_eq_sqrt_inner)

lemma norm_eq: "norm x = norm y \<longleftrightarrow> inner x x = inner y y"
  apply (subst order_eq_iff)
  apply (auto simp: norm_le)
  done

lemma norm_eq_1: "norm x = 1 \<longleftrightarrow> inner x x = 1"
  by (simp add: norm_eq_sqrt_inner)

lemma inner_divide_left:
  fixes a :: "'a :: {real_inner,real_div_algebra}"
  shows "inner (a / of_real m) b = (inner a b) / m"
  by (metis (no_types) divide_inverse inner_commute inner_scaleR_right mult.left_neutral mult.right_neutral mult_scaleR_right of_real_inverse scaleR_conv_of_real times_divide_eq_left)

lemma inner_divide_right:
  fixes a :: "'a :: {real_inner,real_div_algebra}"
  shows "inner a (b / of_real m) = (inner a b) / m"
  by (metis inner_commute inner_divide_left)

text \<open>
  Re-enable constraints for \<^term>\<open>open\<close>, \<^term>\<open>uniformity\<close>,
  \<^term>\<open>dist\<close>, and \<^term>\<open>norm\<close>.
\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>open\<close>, SOME \<^typ>\<open>'a::topological_space set \<Rightarrow> bool\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>uniformity\<close>, SOME \<^typ>\<open>('a::uniform_space \<times> 'a) filter\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>dist\<close>, SOME \<^typ>\<open>'a::metric_space \<Rightarrow> 'a \<Rightarrow> real\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>norm\<close>, SOME \<^typ>\<open>'a::real_normed_vector \<Rightarrow> real\<close>)\<close>

lemma bounded_bilinear_inner:
  "bounded_bilinear (inner::'a::real_inner \<Rightarrow> 'a \<Rightarrow> real)"
proof
  fix x y z :: 'a and r :: real
  show "inner (x + y) z = inner x z + inner y z"
    by (rule inner_add_left)
  show "inner x (y + z) = inner x y + inner x z"
    by (rule inner_add_right)
  show "inner (scaleR r x) y = scaleR r (inner x y)"
    unfolding real_scaleR_def by (rule inner_scaleR_left)
  show "inner x (scaleR r y) = scaleR r (inner x y)"
    unfolding real_scaleR_def by (rule inner_scaleR_right)
  show "\<exists>K. \<forall>x y::'a. norm (inner x y) \<le> norm x * norm y * K"
  proof
    show "\<forall>x y::'a. norm (inner x y) \<le> norm x * norm y * 1"
      by (simp add: Cauchy_Schwarz_ineq2)
  qed
qed

lemmas tendsto_inner [tendsto_intros] =
  bounded_bilinear.tendsto [OF bounded_bilinear_inner]

lemmas isCont_inner [simp] =
  bounded_bilinear.isCont [OF bounded_bilinear_inner]

lemmas has_derivative_inner [derivative_intros] =
  bounded_bilinear.FDERIV [OF bounded_bilinear_inner]

lemmas bounded_linear_inner_left =
  bounded_bilinear.bounded_linear_left [OF bounded_bilinear_inner]

lemmas bounded_linear_inner_right =
  bounded_bilinear.bounded_linear_right [OF bounded_bilinear_inner]

lemmas bounded_linear_inner_left_comp = bounded_linear_inner_left[THEN bounded_linear_compose]

lemmas bounded_linear_inner_right_comp = bounded_linear_inner_right[THEN bounded_linear_compose]

lemmas has_derivative_inner_right [derivative_intros] =
  bounded_linear.has_derivative [OF bounded_linear_inner_right]

lemmas has_derivative_inner_left [derivative_intros] =
  bounded_linear.has_derivative [OF bounded_linear_inner_left]

lemma differentiable_inner [simp]:
  "f differentiable (at x within s) \<Longrightarrow> g differentiable at x within s \<Longrightarrow> (\<lambda>x. inner (f x) (g x)) differentiable at x within s"
  unfolding differentiable_def by (blast intro: has_derivative_inner)

subsection \<open>Class instances\<close>

instantiation real :: real_inner
begin

definition inner_real_def [simp]: "inner = (*)"

instance
proof
  fix x y z r :: real
  show "inner x y = inner y x"
    unfolding inner_real_def by (rule mult.commute)
  show "inner (x + y) z = inner x z + inner y z"
    unfolding inner_real_def by (rule distrib_right)
  show "inner (scaleR r x) y = r * inner x y"
    unfolding inner_real_def real_scaleR_def by (rule mult.assoc)
  show "0 \<le> inner x x"
    unfolding inner_real_def by simp
  show "inner x x = 0 \<longleftrightarrow> x = 0"
    unfolding inner_real_def by simp
  show "norm x = sqrt (inner x x)"
    unfolding inner_real_def by simp
qed

end

lemma
  shows real_inner_1_left[simp]: "inner 1 x = x"
    and real_inner_1_right[simp]: "inner x 1 = x"
  by simp_all

instantiation complex :: real_inner
begin

definition inner_complex_def:
  "inner x y = Re x * Re y + Im x * Im y"

instance
proof
  fix x y z :: complex and r :: real
  show "inner x y = inner y x"
    unfolding inner_complex_def by (simp add: mult.commute)
  show "inner (x + y) z = inner x z + inner y z"
    unfolding inner_complex_def by (simp add: distrib_right)
  show "inner (scaleR r x) y = r * inner x y"
    unfolding inner_complex_def by (simp add: distrib_left)
  show "0 \<le> inner x x"
    unfolding inner_complex_def by simp
  show "inner x x = 0 \<longleftrightarrow> x = 0"
    unfolding inner_complex_def
    by (simp add: add_nonneg_eq_0_iff complex_eq_iff)
  show "norm x = sqrt (inner x x)"
    unfolding inner_complex_def norm_complex_def
    by (simp add: power2_eq_square)
qed

end

lemma complex_inner_1 [simp]: "inner 1 x = Re x"
  unfolding inner_complex_def by simp

lemma complex_inner_1_right [simp]: "inner x 1 = Re x"
  unfolding inner_complex_def by simp

lemma complex_inner_i_left [simp]: "inner \<i> x = Im x"
  unfolding inner_complex_def by simp

lemma complex_inner_i_right [simp]: "inner x \<i> = Im x"
  unfolding inner_complex_def by simp

lemma dot_square_norm: "inner x x = (norm x)\<^sup>2"
  by (simp only: power2_norm_eq_inner) (* TODO: move? *)

lemma norm_eq_square: "norm x = a \<longleftrightarrow> 0 \<le> a \<and> inner x x = a\<^sup>2"
  by (auto simp add: norm_eq_sqrt_inner)

lemma norm_le_square: "norm x \<le> a \<longleftrightarrow> 0 \<le> a \<and> inner x x \<le> a\<^sup>2"
  apply (simp add: dot_square_norm abs_le_square_iff[symmetric])
  using norm_ge_zero[of x]
  apply arith
  done

lemma norm_ge_square: "norm x \<ge> a \<longleftrightarrow> a \<le> 0 \<or> inner x x \<ge> a\<^sup>2"
  apply (simp add: dot_square_norm abs_le_square_iff[symmetric])
  using norm_ge_zero[of x]
  apply arith
  done

lemma norm_lt_square: "norm x < a \<longleftrightarrow> 0 < a \<and> inner x x < a\<^sup>2"
  by (metis not_le norm_ge_square)

lemma norm_gt_square: "norm x > a \<longleftrightarrow> a < 0 \<or> inner x x > a\<^sup>2"
  by (metis norm_le_square not_less)

text\<open>Dot product in terms of the norm rather than conversely.\<close>

lemmas inner_simps = inner_add_left inner_add_right inner_diff_right inner_diff_left
  inner_scaleR_left inner_scaleR_right

lemma dot_norm: "inner x y = ((norm (x + y))\<^sup>2 - (norm x)\<^sup>2 - (norm y)\<^sup>2) / 2"
  by (simp only: power2_norm_eq_inner inner_simps inner_commute) auto

lemma dot_norm_neg: "inner x y = (((norm x)\<^sup>2 + (norm y)\<^sup>2) - (norm (x - y))\<^sup>2) / 2"
  by (simp only: power2_norm_eq_inner inner_simps inner_commute)
    (auto simp add: algebra_simps)

lemma of_real_inner_1 [simp]:
  "inner (of_real x) (1 :: 'a :: {real_inner, real_normed_algebra_1}) = x"
  by (simp add: of_real_def dot_square_norm)

lemma summable_of_real_iff:
  "summable (\<lambda>x. of_real (f x) :: 'a :: {real_normed_algebra_1,real_inner}) \<longleftrightarrow> summable f"
proof
  assume *: "summable (\<lambda>x. of_real (f x) :: 'a)"
  interpret bounded_linear "\<lambda>x::'a. inner x 1"
    by (rule bounded_linear_inner_left)
  from summable [OF *] show "summable f" by simp
qed (auto intro: summable_of_real)

subsection \<open>Gradient derivative\<close>

definition\<^marker>\<open>tag important\<close>
  gderiv ::
    "['a::real_inner \<Rightarrow> real, 'a, 'a] \<Rightarrow> bool"
          ("(GDERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60)
where
  "GDERIV f x :> D \<longleftrightarrow> FDERIV f x :> (\<lambda>h. inner h D)"

lemma gderiv_deriv [simp]: "GDERIV f x :> D \<longleftrightarrow> DERIV f x :> D"
  by (simp only: gderiv_def has_field_derivative_def inner_real_def mult_commute_abs)

lemma GDERIV_DERIV_compose:
    "\<lbrakk>GDERIV f x :> df; DERIV g (f x) :> dg\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. g (f x)) x :> scaleR dg df"
  unfolding gderiv_def has_field_derivative_def
  apply (drule (1) has_derivative_compose)
  apply (simp add: ac_simps)
  done

lemma has_derivative_subst: "\<lbrakk>FDERIV f x :> df; df = d\<rbrakk> \<Longrightarrow> FDERIV f x :> d"
  by simp

lemma GDERIV_subst: "\<lbrakk>GDERIV f x :> df; df = d\<rbrakk> \<Longrightarrow> GDERIV f x :> d"
  by simp

lemma GDERIV_const: "GDERIV (\<lambda>x. k) x :> 0"
  unfolding gderiv_def inner_zero_right by (rule has_derivative_const)

lemma GDERIV_add:
    "\<lbrakk>GDERIV f x :> df; GDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. f x + g x) x :> df + dg"
  unfolding gderiv_def inner_add_right by (rule has_derivative_add)

lemma GDERIV_minus:
    "GDERIV f x :> df \<Longrightarrow> GDERIV (\<lambda>x. - f x) x :> - df"
  unfolding gderiv_def inner_minus_right by (rule has_derivative_minus)

lemma GDERIV_diff:
    "\<lbrakk>GDERIV f x :> df; GDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. f x - g x) x :> df - dg"
  unfolding gderiv_def inner_diff_right by (rule has_derivative_diff)

lemma GDERIV_scaleR:
    "\<lbrakk>DERIV f x :> df; GDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. scaleR (f x) (g x)) x
      :> (scaleR (f x) dg + scaleR df (g x))"
  unfolding gderiv_def has_field_derivative_def inner_add_right inner_scaleR_right
  apply (rule has_derivative_subst)
  apply (erule (1) has_derivative_scaleR)
  apply (simp add: ac_simps)
  done

lemma GDERIV_mult:
    "\<lbrakk>GDERIV f x :> df; GDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. f x * g x) x :> scaleR (f x) dg + scaleR (g x) df"
  unfolding gderiv_def
  apply (rule has_derivative_subst)
  apply (erule (1) has_derivative_mult)
  apply (simp add: inner_add ac_simps)
  done

lemma GDERIV_inverse:
    "\<lbrakk>GDERIV f x :> df; f x \<noteq> 0\<rbrakk>
     \<Longrightarrow> GDERIV (\<lambda>x. inverse (f x)) x :> - (inverse (f x))\<^sup>2 *\<^sub>R df"
  by (metis DERIV_inverse GDERIV_DERIV_compose numerals(2))

lemma GDERIV_norm:
  assumes "x \<noteq> 0" shows "GDERIV (\<lambda>x. norm x) x :> sgn x"
    unfolding gderiv_def norm_eq_sqrt_inner
    by (rule derivative_eq_intros | force simp add: inner_commute sgn_div_norm norm_eq_sqrt_inner assms)+

lemmas has_derivative_norm = GDERIV_norm [unfolded gderiv_def]

bundle inner_syntax begin
notation inner (infix "\<bullet>" 70)
end

bundle no_inner_syntax begin
no_notation inner (infix "\<bullet>" 70)
end

end


(* Author: Tobias Nipkow *)

section "Skew Heap Analysis"

theory Skew_Heap_Analysis
imports
  Complex_Main
  Skew_Heap.Skew_Heap
  Amortized_Framework
  Priority_Queue_ops_merge
begin

text\<open>The following proof is a simplified version of the one by Kaldewaij and
Schoenmakers~\<^cite>\<open>"KaldewaijS-IPL91"\<close>.\<close>

text \<open>right-heavy:\<close>
definition rh :: "'a tree => 'a tree => nat" where
"rh l r = (if size l < size r then 1 else 0)"

text \<open>Function \<open>\<Gamma>\<close> in \<^cite>\<open>"KaldewaijS-IPL91"\<close>: number of right-heavy nodes on left spine.\<close>
fun lrh :: "'a tree \<Rightarrow> nat" where
"lrh Leaf = 0" |
"lrh (Node l _ r) = rh l r + lrh l"

text \<open>Function \<open>\<Delta>\<close> in \<^cite>\<open>"KaldewaijS-IPL91"\<close>: number of not-right-heavy nodes on right spine.\<close>
fun rlh :: "'a tree \<Rightarrow> nat" where
"rlh Leaf = 0" |
"rlh (Node l _ r) = (1 - rh l r) + rlh r"

lemma Gexp: "2 ^ lrh t \<le> size t + 1"
by (induction t) (auto simp: rh_def)

corollary Glog: "lrh t \<le> log 2 (size1 t)"
by (metis Gexp le_log2_of_power size1_size)

lemma Dexp: "2 ^ rlh t \<le> size t + 1"
by (induction t) (auto simp: rh_def)

corollary Dlog: "rlh t \<le> log 2 (size1 t)"
by (metis Dexp le_log2_of_power size1_size)

function T_merge :: "'a::linorder tree \<Rightarrow> 'a tree \<Rightarrow> nat" where
"T_merge Leaf t = 1" |
"T_merge t Leaf = 1" |
"T_merge (Node l1 a1 r1) (Node l2 a2 r2) =
   (if a1 \<le> a2 then T_merge (Node l2 a2 r2) r1 else T_merge (Node l1 a1 r1) r2) + 1"
by pat_completeness auto
termination
by (relation "measure (\<lambda>(x, y). size x + size y)") auto

fun \<Phi> :: "'a tree \<Rightarrow> int" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l _ r) = \<Phi> l + \<Phi> r + rh l r"

lemma \<Phi>_nneg: "\<Phi> t \<ge> 0"
by (induction t) auto

lemma plus_log_le_2log_plus: "\<lbrakk> x > 0; y > 0; b > 1 \<rbrakk>
  \<Longrightarrow> log b x + log b y \<le> 2 * log b (x + y)"
by(subst mult_2; rule add_mono; auto)

lemma rh1: "rh l r \<le> 1"
by(simp add: rh_def)

lemma amor_le_long:
  "T_merge t1 t2 + \<Phi> (merge t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   lrh(merge t1 t2) + rlh t1 + rlh t2 + 1"
proof (induction t1 t2 rule: merge.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 l1 a1 r1 l2 a2 r2)
  show ?case
  proof (cases "a1 \<le> a2")
    case True
    let ?t1 = "Node l1 a1 r1" let ?t2 = "Node l2 a2 r2" let ?m = "merge ?t2 r1"
    have "T_merge ?t1 ?t2 + \<Phi> (merge ?t1 ?t2) - \<Phi> ?t1 - \<Phi> ?t2
          = T_merge ?t2 r1 + 1 + \<Phi> ?m + \<Phi> l1 + rh ?m l1 - \<Phi> ?t1 - \<Phi> ?t2"
      using True by (simp)
    also have "\<dots> = T_merge ?t2 r1 + 1 + \<Phi> ?m + rh ?m l1 - \<Phi> r1 - rh l1 r1 - \<Phi> ?t2"
      by simp
    also have "\<dots> \<le> lrh ?m + rlh ?t2 + rlh r1 + rh ?m l1 + 2 - rh l1 r1"
      using "3.IH"(1)[OF True] by linarith
    also have "\<dots> = lrh ?m + rlh ?t2 + rlh r1 + rh ?m l1 + 1 + (1 - rh l1 r1)"
      using rh1[of l1 r1] by (simp)
    also have "\<dots> = lrh ?m + rlh ?t2 + rlh ?t1 + rh ?m l1 + 1"
      by (simp)
    also have "\<dots> = lrh (merge ?t1 ?t2) + rlh ?t1 + rlh ?t2 + 1"
      using True by(simp)
    finally show ?thesis .
  next
    case False with 3 show ?thesis by auto
  qed
qed

lemma amor_le:
  "T_merge t1 t2 + \<Phi> (merge t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   lrh(merge t1 t2) + rlh t1 + rlh t2 + 1"
by(induction t1 t2 rule: merge.induct)(auto)

lemma a_merge:
  "T_merge t1 t2 + \<Phi>(merge t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   3 * log 2 (size1 t1 + size1 t2) + 1" (is "?l \<le> _")
proof -
  have "?l \<le> lrh(merge t1 t2) + rlh t1 + rlh t2 + 1" using amor_le[of t1 t2] by arith
  also have "\<dots> = real(lrh(merge t1 t2)) + rlh t1 + rlh t2 + 1" by simp
  also have "\<dots> = real(lrh(merge t1 t2)) + (real(rlh t1) + rlh t2) + 1" by simp
  also have "rlh t1 \<le> log 2 (size1 t1)" by(rule Dlog)
  also have "rlh t2 \<le> log 2 (size1 t2)" by(rule Dlog)
  also have "lrh (merge t1 t2) \<le> log 2 (size1(merge t1 t2))" by(rule Glog)
  also have "size1(merge t1 t2) = size1 t1 + size1 t2 - 1" by(simp add: size1_size size_merge)
  also have "log 2 (size1 t1 + size1 t2 - 1) \<le> log 2 (size1 t1 + size1 t2)" by(simp add: size1_size)
  also have "log 2 (size1 t1) + log 2 (size1 t2) \<le> 2 * log 2 (real(size1 t1) + (size1 t2))"
    by(rule plus_log_le_2log_plus) (auto simp: size1_size)
  finally show ?thesis by(simp)
qed

definition T_insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> int" where
"T_insert a t = T_merge (Node Leaf a Leaf) t + 1"

lemma a_insert: "T_insert a t + \<Phi>(skew_heap.insert a t) - \<Phi> t \<le> 3 * log 2 (size1 t + 2) + 2"
using a_merge[of "Node Leaf a Leaf" "t"]
by (simp add: numeral_eq_Suc T_insert_def rh_def)

definition T_del_min :: "('a::linorder) tree \<Rightarrow> int" where
"T_del_min t = (case t of Leaf \<Rightarrow> 1 | Node t1 a t2 \<Rightarrow> T_merge t1 t2 + 1)"

lemma a_del_min: "T_del_min t + \<Phi>(skew_heap.del_min t) - \<Phi> t \<le> 3 * log 2 (size1 t + 2) + 2"
proof (cases t)
  case Leaf thus ?thesis by (simp add: T_del_min_def)
next
  case (Node t1 _ t2)
  have [arith]: "log 2 (2 + (real (size t1) + real (size t2))) \<le>
                log 2 (4 + (real (size t1) + real (size t2)))" by simp
  from Node show ?thesis using a_merge[of t1 t2]
    by (simp add: size1_size T_del_min_def rh_def)
qed

subsubsection "Instantiation of Amortized Framework"

lemma T_merge_nneg: "T_merge t1 t2 \<ge> 0"
by(induction t1 t2 rule: T_merge.induct) auto

fun exec :: "'a::linorder op \<Rightarrow> 'a tree list \<Rightarrow> 'a tree" where
"exec Empty [] = Leaf" |
"exec (Insert a) [t] = skew_heap.insert a t" |
"exec Del_min [t] = skew_heap.del_min t" |
"exec Merge [t1,t2] = merge t1 t2"

fun cost :: "'a::linorder op \<Rightarrow> 'a tree list \<Rightarrow> nat" where
"cost Empty [] = 1" |
"cost (Insert a) [t] = T_merge (Node Leaf a Leaf) t + 1" |
"cost Del_min [t] = (case t of Leaf \<Rightarrow> 1 | Node t1 a t2 \<Rightarrow> T_merge t1 t2 + 1)" |
"cost Merge [t1,t2] = T_merge t1 t2"

fun U where
"U Empty [] = 1" |
"U (Insert _) [t] = 3 * log 2 (size1 t + 2) + 2" |
"U Del_min [t] = 3 * log 2 (size1 t + 2) + 2" |
"U Merge [t1,t2] = 3 * log 2 (size1 t1 + size1 t2) + 1"

interpretation Amortized
where arity = arity and exec = exec and inv = "\<lambda>_. True"
and cost = cost and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case (2 t) show ?case using \<Phi>_nneg[of t] by linarith
next
  case (3 ss f)
  show ?case
  proof (cases f)
    case Empty thus ?thesis using 3(2) by (auto)
  next
    case [simp]: (Insert a)
    obtain t where [simp]: "ss = [t]" using 3(2) by (auto)
    thus ?thesis using a_merge[of "Node Leaf a Leaf" "t"]
      by (simp add: numeral_eq_Suc insert_def rh_def T_merge_nneg)
  next
    case [simp]: Del_min
    obtain t where [simp]: "ss = [t]" using 3(2) by (auto)
    thus ?thesis
    proof (cases t)
      case Leaf with Del_min show ?thesis by simp
    next
      case (Node t1 _ t2)
      have [arith]: "log 2 (2 + (real (size t1) + real (size t2))) \<le>
               log 2 (4 + (real (size t1) + real (size t2)))" by simp
      from Del_min Node show ?thesis using a_merge[of t1 t2]
        by (simp add: size1_size T_merge_nneg)
    qed
  next
    case [simp]: Merge
    obtain t1 t2 where "ss = [t1,t2]" using 3(2) by (auto simp: numeral_eq_Suc)
    thus ?thesis using a_merge[of t1 t2] by (simp add: T_merge_nneg)
  qed
qed

end


theory Ex007
imports Main
begin

(*Peirce's Law*)

lemma "(( A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
proof -
{
  assume "(A \<longrightarrow> B) \<longrightarrow> A"
  {
    assume a:"\<not>A"
    {
      assume A
      with a have B by contradiction
    }
    hence "A \<longrightarrow> B" by (rule impI)
    with \<open>(A \<longrightarrow> B) \<longrightarrow> A\<close> have A by (rule impE)
    with \<open>\<not>A\<close> have False by contradiction
  }
  hence "\<not>\<not>A" by (rule notI)
  hence A by (rule notnotD)
}
thus ?thesis by (rule impI)
qed

(*slightly prettified*)

lemma "(( A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
proof -
{
  assume "(A \<longrightarrow> B) \<longrightarrow> A"
  {
    assume a:"\<not>A"
    {
      assume A
      with a have B ..
    }
    hence "A \<longrightarrow> B" ..
    with \<open>(A \<longrightarrow> B) \<longrightarrow> A\<close> have A ..
    with \<open>\<not>A\<close> have False ..
  }
  hence "\<not>\<not>A" ..
  hence A by (rule notnotD)
}
thus ?thesis ..
qed

lemma "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
proof -
  {
    assume a:"((A \<longrightarrow> B) \<longrightarrow> A)"
    {
      assume b:"\<not>A"
      {
        assume c:A
        {
          assume "\<not>B"
          from b and c have False by contradiction
        }
        hence "\<not>\<not>B" by (rule notI)
        hence B by (rule notnotD)
      }
      hence "A \<longrightarrow> B" by (rule impI)
      with a have A by (rule mp)
      with b have False by contradiction
    }
    hence "\<not>\<not>A" by (rule notI)
    hence A by (rule notnotD)
  }
  thus "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A" by (rule impI)
qed


(*  Title:      HOL/Analysis/Euclidean_Space.thy
    Author:     Johannes Hölzl, TU München
    Author:     Brian Huffman, Portland State University
*)

section \<open>Finite-Dimensional Inner Product Spaces\<close>

theory Euclidean_Space
imports
  L2_Norm
  Inner_Product
  Product_Vector
begin

subsection\<^marker>\<open>tag unimportant\<close> \<open>Interlude: Some properties of real sets\<close>

lemma seq_mono_lemma:
  assumes "\<forall>(n::nat) \<ge> m. (d n :: real) < e n"
    and "\<forall>n \<ge> m. e n \<le> e m"
  shows "\<forall>n \<ge> m. d n < e m"
  using assms by force

subsection \<open>Type class of Euclidean spaces\<close>

class euclidean_space = real_inner +
  fixes Basis :: "'a set"
  assumes nonempty_Basis [simp]: "Basis \<noteq> {}"
  assumes finite_Basis [simp]: "finite Basis"
  assumes inner_Basis:
    "\<lbrakk>u \<in> Basis; v \<in> Basis\<rbrakk> \<Longrightarrow> inner u v = (if u = v then 1 else 0)"
  assumes euclidean_all_zero_iff:
    "(\<forall>u\<in>Basis. inner x u = 0) \<longleftrightarrow> (x = 0)"

syntax "_type_dimension" :: "type \<Rightarrow> nat"  ("(1DIM/(1'(_')))")
translations "DIM('a)" \<rightharpoonup> "CONST card (CONST Basis :: 'a set)"
typed_print_translation \<open>
  [(\<^const_syntax>\<open>card\<close>,
    fn ctxt => fn _ => fn [Const (\<^const_syntax>\<open>Basis\<close>, Type (\<^type_name>\<open>set\<close>, [T]))] =>
      Syntax.const \<^syntax_const>\<open>_type_dimension\<close> $ Syntax_Phases.term_of_typ ctxt T)]
\<close>

lemma (in euclidean_space) norm_Basis[simp]: "u \<in> Basis \<Longrightarrow> norm u = 1"
  unfolding norm_eq_sqrt_inner by (simp add: inner_Basis)

lemma (in euclidean_space) inner_same_Basis[simp]: "u \<in> Basis \<Longrightarrow> inner u u = 1"
  by (simp add: inner_Basis)

lemma (in euclidean_space) inner_not_same_Basis: "u \<in> Basis \<Longrightarrow> v \<in> Basis \<Longrightarrow> u \<noteq> v \<Longrightarrow> inner u v = 0"
  by (simp add: inner_Basis)

lemma (in euclidean_space) sgn_Basis: "u \<in> Basis \<Longrightarrow> sgn u = u"
  unfolding sgn_div_norm by (simp add: scaleR_one)

lemma inner_sum_Basis[simp]: "i \<in> Basis \<Longrightarrow> inner (\<Sum>Basis) i = 1"
  by (simp add: inner_sum_left sum.If_cases inner_Basis)

lemma (in euclidean_space) Basis_zero [simp]: "0 \<notin> Basis"
proof
  assume "0 \<in> Basis" thus "False"
    using inner_Basis [of 0 0] by simp
qed

lemma (in euclidean_space) nonzero_Basis: "u \<in> Basis \<Longrightarrow> u \<noteq> 0"
  by clarsimp

lemma (in euclidean_space) SOME_Basis: "(SOME i. i \<in> Basis) \<in> Basis"
  by (metis ex_in_conv nonempty_Basis someI_ex)

lemma norm_some_Basis [simp]: "norm (SOME i. i \<in> Basis) = 1"
  by (simp add: SOME_Basis)

lemma (in euclidean_space) inner_sum_left_Basis[simp]:
    "b \<in> Basis \<Longrightarrow> inner (\<Sum>i\<in>Basis. f i *\<^sub>R i) b = f b"
  by (simp add: inner_sum_left inner_Basis if_distrib comm_monoid_add_class.sum.If_cases)

lemma (in euclidean_space) euclidean_eqI:
  assumes b: "\<And>b. b \<in> Basis \<Longrightarrow> inner x b = inner y b" shows "x = y"
proof -
  from b have "\<forall>b\<in>Basis. inner (x - y) b = 0"
    by (simp add: inner_diff_left)
  then show "x = y"
    by (simp add: euclidean_all_zero_iff)
qed

lemma (in euclidean_space) euclidean_eq_iff:
  "x = y \<longleftrightarrow> (\<forall>b\<in>Basis. inner x b = inner y b)"
  by (auto intro: euclidean_eqI)

lemma (in euclidean_space) euclidean_representation_sum:
  "(\<Sum>i\<in>Basis. f i *\<^sub>R i) = b \<longleftrightarrow> (\<forall>i\<in>Basis. f i = inner b i)"
  by (subst euclidean_eq_iff) simp

lemma (in euclidean_space) euclidean_representation_sum':
  "b = (\<Sum>i\<in>Basis. f i *\<^sub>R i) \<longleftrightarrow> (\<forall>i\<in>Basis. f i = inner b i)"
  by (auto simp add: euclidean_representation_sum[symmetric])

lemma (in euclidean_space) euclidean_representation: "(\<Sum>b\<in>Basis. inner x b *\<^sub>R b) = x"
  unfolding euclidean_representation_sum by simp

lemma (in euclidean_space) euclidean_inner: "inner x y = (\<Sum>b\<in>Basis. (inner x b) * (inner y b))"
  by (subst (1 2) euclidean_representation [symmetric])
    (simp add: inner_sum_right inner_Basis ac_simps)

lemma (in euclidean_space) choice_Basis_iff:
  fixes P :: "'a \<Rightarrow> real \<Rightarrow> bool"
  shows "(\<forall>i\<in>Basis. \<exists>x. P i x) \<longleftrightarrow> (\<exists>x. \<forall>i\<in>Basis. P i (inner x i))"
  unfolding bchoice_iff
proof safe
  fix f assume "\<forall>i\<in>Basis. P i (f i)"
  then show "\<exists>x. \<forall>i\<in>Basis. P i (inner x i)"
    by (auto intro!: exI[of _ "\<Sum>i\<in>Basis. f i *\<^sub>R i"])
qed auto

lemma (in euclidean_space) bchoice_Basis_iff:
  fixes P :: "'a \<Rightarrow> real \<Rightarrow> bool"
  shows "(\<forall>i\<in>Basis. \<exists>x\<in>A. P i x) \<longleftrightarrow> (\<exists>x. \<forall>i\<in>Basis. inner x i \<in> A \<and> P i (inner x i))"
by (simp add: choice_Basis_iff Bex_def)

lemma (in euclidean_space) euclidean_representation_sum_fun:
    "(\<lambda>x. \<Sum>b\<in>Basis. inner (f x) b *\<^sub>R b) = f"
  by (rule ext) (simp add: euclidean_representation_sum)

lemma euclidean_isCont:
  assumes "\<And>b. b \<in> Basis \<Longrightarrow> isCont (\<lambda>x. (inner (f x) b) *\<^sub>R b) x"
    shows "isCont f x"
  apply (subst euclidean_representation_sum_fun [symmetric])
  apply (rule isCont_sum)
  apply (blast intro: assms)
  done

lemma DIM_positive [simp]: "0 < DIM('a::euclidean_space)"
  by (simp add: card_gt_0_iff)

lemma DIM_ge_Suc0 [simp]: "Suc 0 \<le> card Basis"
  by (meson DIM_positive Suc_leI)

lemma sum_inner_Basis_scaleR [simp]:
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::real_vector"
  assumes "b \<in> Basis" shows "(\<Sum>i\<in>Basis. (inner i b) *\<^sub>R f i) = f b"
  by (simp add: comm_monoid_add_class.sum.remove [OF finite_Basis assms]
         assms inner_not_same_Basis comm_monoid_add_class.sum.neutral)

lemma sum_inner_Basis_eq [simp]:
  assumes "b \<in> Basis" shows "(\<Sum>i\<in>Basis. (inner i b) * f i) = f b"
  by (simp add: comm_monoid_add_class.sum.remove [OF finite_Basis assms]
         assms inner_not_same_Basis comm_monoid_add_class.sum.neutral)

lemma sum_if_inner [simp]:
  assumes "i \<in> Basis" "j \<in> Basis"
    shows "inner (\<Sum>k\<in>Basis. if k = i then f i *\<^sub>R i else g k *\<^sub>R k) j = (if j=i then f j else g j)"
proof (cases "i=j")
  case True
  with assms show ?thesis
    by (auto simp: inner_sum_left if_distrib [of "\<lambda>x. inner x j"] inner_Basis cong: if_cong)
next
  case False
  have "(\<Sum>k\<in>Basis. inner (if k = i then f i *\<^sub>R i else g k *\<^sub>R k) j) =
        (\<Sum>k\<in>Basis. if k = j then g k else 0)"
    apply (rule sum.cong)
    using False assms by (auto simp: inner_Basis)
  also have "... = g j"
    using assms by auto
  finally show ?thesis
    using False by (auto simp: inner_sum_left)
qed

lemma norm_le_componentwise:
   "(\<And>b. b \<in> Basis \<Longrightarrow> abs(inner x b) \<le> abs(inner y b)) \<Longrightarrow> norm x \<le> norm y"
  by (auto simp: norm_le euclidean_inner [of x x] euclidean_inner [of y y] abs_le_square_iff power2_eq_square intro!: sum_mono)

lemma Basis_le_norm: "b \<in> Basis \<Longrightarrow> \<bar>inner x b\<bar> \<le> norm x"
  by (rule order_trans [OF Cauchy_Schwarz_ineq2]) simp

lemma norm_bound_Basis_le: "b \<in> Basis \<Longrightarrow> norm x \<le> e \<Longrightarrow> \<bar>inner x b\<bar> \<le> e"
  by (metis Basis_le_norm order_trans)

lemma norm_bound_Basis_lt: "b \<in> Basis \<Longrightarrow> norm x < e \<Longrightarrow> \<bar>inner x b\<bar> < e"
  by (metis Basis_le_norm le_less_trans)

lemma norm_le_l1: "norm x \<le> (\<Sum>b\<in>Basis. \<bar>inner x b\<bar>)"
  apply (subst euclidean_representation[of x, symmetric])
  apply (rule order_trans[OF norm_sum])
  apply (auto intro!: sum_mono)
  done

lemma sum_norm_allsubsets_bound:
  fixes f :: "'a \<Rightarrow> 'n::euclidean_space"
  assumes fP: "finite P"
    and fPs: "\<And>Q. Q \<subseteq> P \<Longrightarrow> norm (sum f Q) \<le> e"
  shows "(\<Sum>x\<in>P. norm (f x)) \<le> 2 * real DIM('n) * e"
proof -
  have "(\<Sum>x\<in>P. norm (f x)) \<le> (\<Sum>x\<in>P. \<Sum>b\<in>Basis. \<bar>inner (f x) b\<bar>)"
    by (rule sum_mono) (rule norm_le_l1)
  also have "(\<Sum>x\<in>P. \<Sum>b\<in>Basis. \<bar>inner (f x) b\<bar>) = (\<Sum>b\<in>Basis. \<Sum>x\<in>P. \<bar>inner (f x) b\<bar>)"
    by (rule sum.swap)
  also have "\<dots> \<le> of_nat (card (Basis :: 'n set)) * (2 * e)"
  proof (rule sum_bounded_above)
    fix i :: 'n
    assume i: "i \<in> Basis"
    have "norm (\<Sum>x\<in>P. \<bar>inner (f x) i\<bar>) \<le>
      norm (inner (\<Sum>x\<in>P \<inter> - {x. inner (f x) i < 0}. f x) i) + norm (inner (\<Sum>x\<in>P \<inter> {x. inner (f x) i < 0}. f x) i)"
      by (simp add: abs_real_def sum.If_cases[OF fP] sum_negf norm_triangle_ineq4 inner_sum_left
        del: real_norm_def)
    also have "\<dots> \<le> e + e"
      unfolding real_norm_def
      by (intro add_mono norm_bound_Basis_le i fPs) auto
    finally show "(\<Sum>x\<in>P. \<bar>inner (f x) i\<bar>) \<le> 2*e" by simp
  qed
  also have "\<dots> = 2 * real DIM('n) * e" by simp
  finally show ?thesis .
qed

subsection\<^marker>\<open>tag unimportant\<close> \<open>Subclass relationships\<close>

instance euclidean_space \<subseteq> perfect_space
proof
  fix x :: 'a show "\<not> open {x}"
  proof
    assume "open {x}"
    then obtain e where "0 < e" and e: "\<forall>y. dist y x < e \<longrightarrow> y = x"
      unfolding open_dist by fast
    define y where "y = x + scaleR (e/2) (SOME b. b \<in> Basis)"
    have [simp]: "(SOME b. b \<in> Basis) \<in> Basis"
      by (rule someI_ex) (auto simp: ex_in_conv)
    from \<open>0 < e\<close> have "y \<noteq> x"
      unfolding y_def by (auto intro!: nonzero_Basis)
    from \<open>0 < e\<close> have "dist y x < e"
      unfolding y_def by (simp add: dist_norm)
    from \<open>y \<noteq> x\<close> and \<open>dist y x < e\<close> show "False"
      using e by simp
  qed
qed

subsection \<open>Class instances\<close>

subsubsection\<^marker>\<open>tag unimportant\<close> \<open>Type \<^typ>\<open>real\<close>\<close>

instantiation real :: euclidean_space
begin

definition
  [simp]: "Basis = {1::real}"

instance
  by standard auto

end

lemma DIM_real[simp]: "DIM(real) = 1"
  by simp

subsubsection\<^marker>\<open>tag unimportant\<close> \<open>Type \<^typ>\<open>complex\<close>\<close>

instantiation complex :: euclidean_space
begin

definition Basis_complex_def: "Basis = {1, \<i>}"

instance
  by standard (auto simp add: Basis_complex_def intro: complex_eqI split: if_split_asm)

end

lemma DIM_complex[simp]: "DIM(complex) = 2"
  unfolding Basis_complex_def by simp

lemma complex_Basis_1 [iff]: "(1::complex) \<in> Basis"
  by (simp add: Basis_complex_def)

lemma complex_Basis_i [iff]: "\<i> \<in> Basis"
  by (simp add: Basis_complex_def)

subsubsection\<^marker>\<open>tag unimportant\<close> \<open>Type \<^typ>\<open>'a \<times> 'b\<close>\<close>

instantiation prod :: (real_inner, real_inner) real_inner
begin

definition inner_prod_def:
  "inner x y = inner (fst x) (fst y) + inner (snd x) (snd y)"

lemma inner_Pair [simp]: "inner (a, b) (c, d) = inner a c + inner b d"
  unfolding inner_prod_def by simp

instance
proof
  fix r :: real
  fix x y z :: "'a::real_inner \<times> 'b::real_inner"
  show "inner x y = inner y x"
    unfolding inner_prod_def
    by (simp add: inner_commute)
  show "inner (x + y) z = inner x z + inner y z"
    unfolding inner_prod_def
    by (simp add: inner_add_left)
  show "inner (scaleR r x) y = r * inner x y"
    unfolding inner_prod_def
    by (simp add: distrib_left)
  show "0 \<le> inner x x"
    unfolding inner_prod_def
    by (intro add_nonneg_nonneg inner_ge_zero)
  show "inner x x = 0 \<longleftrightarrow> x = 0"
    unfolding inner_prod_def prod_eq_iff
    by (simp add: add_nonneg_eq_0_iff)
  show "norm x = sqrt (inner x x)"
    unfolding norm_prod_def inner_prod_def
    by (simp add: power2_norm_eq_inner)
qed

end

lemma inner_Pair_0: "inner x (0, b) = inner (snd x) b" "inner x (a, 0) = inner (fst x) a"
    by (cases x, simp)+

instantiation prod :: (euclidean_space, euclidean_space) euclidean_space
begin

definition
  "Basis = (\<lambda>u. (u, 0)) ` Basis \<union> (\<lambda>v. (0, v)) ` Basis"

lemma sum_Basis_prod_eq:
  fixes f::"('a*'b)\<Rightarrow>('a*'b)"
  shows "sum f Basis = sum (\<lambda>i. f (i, 0)) Basis + sum (\<lambda>i. f (0, i)) Basis"
proof -
  have "inj_on (\<lambda>u. (u::'a, 0::'b)) Basis" "inj_on (\<lambda>u. (0::'a, u::'b)) Basis"
    by (auto intro!: inj_onI Pair_inject)
  thus ?thesis
    unfolding Basis_prod_def
    by (subst sum.union_disjoint) (auto simp: Basis_prod_def sum.reindex)
qed

instance proof
  show "(Basis :: ('a \<times> 'b) set) \<noteq> {}"
    unfolding Basis_prod_def by simp
next
  show "finite (Basis :: ('a \<times> 'b) set)"
    unfolding Basis_prod_def by simp
next
  fix u v :: "'a \<times> 'b"
  assume "u \<in> Basis" and "v \<in> Basis"
  thus "inner u v = (if u = v then 1 else 0)"
    unfolding Basis_prod_def inner_prod_def
    by (auto simp add: inner_Basis split: if_split_asm)
next
  fix x :: "'a \<times> 'b"
  show "(\<forall>u\<in>Basis. inner x u = 0) \<longleftrightarrow> x = 0"
    unfolding Basis_prod_def ball_Un ball_simps
    by (simp add: inner_prod_def prod_eq_iff euclidean_all_zero_iff)
qed

lemma DIM_prod[simp]: "DIM('a \<times> 'b) = DIM('a) + DIM('b)"
  unfolding Basis_prod_def
  by (subst card_Un_disjoint) (auto intro!: card_image arg_cong2[where f="(+)"] inj_onI)

end

subsection \<open>Locale instances\<close>

lemma finite_dimensional_vector_space_euclidean:
  "finite_dimensional_vector_space (*\<^sub>R) Basis"
proof unfold_locales
  show "finite (Basis::'a set)" by (metis finite_Basis)
  show "real_vector.independent (Basis::'a set)"
    unfolding dependent_def dependent_raw_def[symmetric]
    apply (subst span_finite)
    apply simp
    apply clarify
    apply (drule_tac f="inner a" in arg_cong)
    apply (simp add: inner_Basis inner_sum_right eq_commute)
    done
  show "module.span (*\<^sub>R) Basis = UNIV"
    unfolding span_finite [OF finite_Basis] span_raw_def[symmetric]
    by (auto intro!: euclidean_representation[symmetric])
qed

interpretation eucl?: finite_dimensional_vector_space "scaleR :: real => 'a => 'a::euclidean_space" "Basis"
  rewrites "module.dependent (*\<^sub>R) = dependent"
    and "module.representation (*\<^sub>R) = representation"
    and "module.subspace (*\<^sub>R) = subspace"
    and "module.span (*\<^sub>R) = span"
    and "vector_space.extend_basis (*\<^sub>R) = extend_basis"
    and "vector_space.dim (*\<^sub>R) = dim"
    and "Vector_Spaces.linear (*\<^sub>R) (*\<^sub>R) = linear"
    and "Vector_Spaces.linear (*) (*\<^sub>R) = linear"
    and "finite_dimensional_vector_space.dimension Basis = DIM('a)"
    and "dimension = DIM('a)"
  by (auto simp add: dependent_raw_def representation_raw_def
      subspace_raw_def span_raw_def extend_basis_raw_def dim_raw_def linear_def
      real_scaleR_def[abs_def]
      finite_dimensional_vector_space.dimension_def
      intro!: finite_dimensional_vector_space.dimension_def
      finite_dimensional_vector_space_euclidean)

interpretation eucl?: finite_dimensional_vector_space_pair_1
  "scaleR::real\<Rightarrow>'a::euclidean_space\<Rightarrow>'a" Basis
  "scaleR::real\<Rightarrow>'b::real_vector \<Rightarrow> 'b"
  by unfold_locales

interpretation eucl?: finite_dimensional_vector_space_prod scaleR scaleR Basis Basis
  rewrites "Basis_pair = Basis"
    and "module_prod.scale (*\<^sub>R) (*\<^sub>R) = (scaleR::_\<Rightarrow>_\<Rightarrow>('a \<times> 'b))"
proof -
  show "finite_dimensional_vector_space_prod (*\<^sub>R) (*\<^sub>R) Basis Basis"
    by unfold_locales
  interpret finite_dimensional_vector_space_prod "(*\<^sub>R)" "(*\<^sub>R)" "Basis::'a set" "Basis::'b set"
    by fact
  show "Basis_pair = Basis"
    unfolding Basis_pair_def Basis_prod_def by auto
  show "module_prod.scale (*\<^sub>R) (*\<^sub>R) = scaleR"
    by (fact module_prod_scale_eq_scaleR)
qed

end


(*  Title:      HOL/Nonstandard_Analysis/HLim.thy
    Author:     Jacques D. Fleuriot, University of Cambridge
    Author:     Lawrence C Paulson
*)

section \<open>Limits and Continuity (Nonstandard)\<close>

theory HLim
  imports Star
  abbrevs "--->" = "\<midarrow>\<rightarrow>\<^sub>N\<^sub>S"
begin

text \<open>Nonstandard Definitions.\<close>

definition NSLIM :: "('a::real_normed_vector \<Rightarrow> 'b::real_normed_vector) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
    ("((_)/ \<midarrow>(_)/\<rightarrow>\<^sub>N\<^sub>S (_))" [60, 0, 60] 60)
  where "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L \<longleftrightarrow> (\<forall>x. x \<noteq> star_of a \<and> x \<approx> star_of a \<longrightarrow> ( *f* f) x \<approx> star_of L)"

definition isNSCont :: "('a::real_normed_vector \<Rightarrow> 'b::real_normed_vector) \<Rightarrow> 'a \<Rightarrow> bool"
  where  \<comment> \<open>NS definition dispenses with limit notions\<close>
    "isNSCont f a \<longleftrightarrow> (\<forall>y. y \<approx> star_of a \<longrightarrow> ( *f* f) y \<approx> star_of (f a))"

definition isNSUCont :: "('a::real_normed_vector \<Rightarrow> 'b::real_normed_vector) \<Rightarrow> bool"
  where "isNSUCont f \<longleftrightarrow> (\<forall>x y. x \<approx> y \<longrightarrow> ( *f* f) x \<approx> ( *f* f) y)"

subsection \<open>Limits of Functions\<close>

lemma NSLIM_I: "(\<And>x. x \<noteq> star_of a \<Longrightarrow> x \<approx> star_of a \<Longrightarrow> starfun f x \<approx> star_of L) \<Longrightarrow> f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L"
  by (simp add: NSLIM_def)

lemma NSLIM_D: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L \<Longrightarrow> x \<noteq> star_of a \<Longrightarrow> x \<approx> star_of a \<Longrightarrow> starfun f x \<approx> star_of L"
  by (simp add: NSLIM_def)

text \<open>Proving properties of limits using nonstandard definition.
  The properties hold for standard limits as well!\<close>

lemma NSLIM_mult: "f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S l \<Longrightarrow> g \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S m \<Longrightarrow> (\<lambda>x. f x * g x) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S (l * m)"
  for l m :: "'a::real_normed_algebra"
  by (auto simp add: NSLIM_def intro!: approx_mult_HFinite)

lemma starfun_scaleR [simp]: "starfun (\<lambda>x. f x *\<^sub>R g x) = (\<lambda>x. scaleHR (starfun f x) (starfun g x))"
  by transfer (rule refl)

lemma NSLIM_scaleR: "f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S l \<Longrightarrow> g \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S m \<Longrightarrow> (\<lambda>x. f x *\<^sub>R g x) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S (l *\<^sub>R m)"
  by (auto simp add: NSLIM_def intro!: approx_scaleR_HFinite)

lemma NSLIM_add: "f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S l \<Longrightarrow> g \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S m \<Longrightarrow> (\<lambda>x. f x + g x) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S (l + m)"
  by (auto simp add: NSLIM_def intro!: approx_add)

lemma NSLIM_const [simp]: "(\<lambda>x. k) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S k"
  by (simp add: NSLIM_def)

lemma NSLIM_minus: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L \<Longrightarrow> (\<lambda>x. - f x) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S -L"
  by (simp add: NSLIM_def)

lemma NSLIM_diff: "f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S l \<Longrightarrow> g \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S m \<Longrightarrow> (\<lambda>x. f x - g x) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S (l - m)"
  by (simp only: NSLIM_add NSLIM_minus diff_conv_add_uminus)

lemma NSLIM_add_minus: "f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S l \<Longrightarrow> g \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S m \<Longrightarrow> (\<lambda>x. f x + - g x) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S (l + -m)"
  by (simp only: NSLIM_add NSLIM_minus)

lemma NSLIM_inverse: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L \<Longrightarrow> L \<noteq> 0 \<Longrightarrow> (\<lambda>x. inverse (f x)) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S (inverse L)"
  for L :: "'a::real_normed_div_algebra"
  unfolding NSLIM_def by (metis (no_types) star_of_approx_inverse star_of_simps(6) starfun_inverse)

lemma NSLIM_zero:
  assumes f: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S l"
  shows "(\<lambda>x. f(x) - l) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S 0"
proof -
  have "(\<lambda>x. f x - l) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S l - l"
    by (rule NSLIM_diff [OF f NSLIM_const])
  then show ?thesis by simp
qed

lemma NSLIM_zero_cancel:
  assumes "(\<lambda>x. f x - l) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S 0"
  shows "f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S l"
proof -
  have "(\<lambda>x. f x - l + l) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S 0 + l"
    by (fast intro: assms NSLIM_const NSLIM_add)
  then show ?thesis
    by simp
qed

lemma NSLIM_const_eq:
  fixes a :: "'a::real_normed_algebra_1"
  assumes "(\<lambda>x. k) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S l"
  shows "k = l"
proof -
  have "\<not> (\<lambda>x. k) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S l" if "k \<noteq> l"
  proof -
    have "star_of a + of_hypreal \<epsilon> \<approx> star_of a"
      by (simp add: approx_def)
    then show ?thesis
      using epsilon_not_zero that by (force simp add: NSLIM_def)
  qed
  with assms show ?thesis by metis
qed

lemma NSLIM_unique: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S l \<Longrightarrow> f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S M \<Longrightarrow> l = M"
  for a :: "'a::real_normed_algebra_1"
  by (drule (1) NSLIM_diff) (auto dest!: NSLIM_const_eq)

lemma NSLIM_mult_zero: "f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S 0 \<Longrightarrow> g \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S 0 \<Longrightarrow> (\<lambda>x. f x * g x) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S 0"
  for f g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_algebra"
  by (drule NSLIM_mult) auto

lemma NSLIM_self: "(\<lambda>x. x) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S a"
  by (simp add: NSLIM_def)

subsubsection \<open>Equivalence of \<^term>\<open>filterlim\<close> and \<^term>\<open>NSLIM\<close>\<close>

lemma LIM_NSLIM:
  assumes f: "f \<midarrow>a\<rightarrow> L"
  shows "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L"
proof (rule NSLIM_I)
  fix x
  assume neq: "x \<noteq> star_of a"
  assume approx: "x \<approx> star_of a"
  have "starfun f x - star_of L \<in> Infinitesimal"
  proof (rule InfinitesimalI2)
    fix r :: real
    assume r: "0 < r"
    from LIM_D [OF f r] obtain s
      where s: "0 < s" and less_r: "\<And>x. x \<noteq> a \<Longrightarrow> norm (x - a) < s \<Longrightarrow> norm (f x - L) < r"
      by fast
    from less_r have less_r':
      "\<And>x. x \<noteq> star_of a \<Longrightarrow> hnorm (x - star_of a) < star_of s \<Longrightarrow>
        hnorm (starfun f x - star_of L) < star_of r"
      by transfer
    from approx have "x - star_of a \<in> Infinitesimal"
      by (simp only: approx_def)
    then have "hnorm (x - star_of a) < star_of s"
      using s by (rule InfinitesimalD2)
    with neq show "hnorm (starfun f x - star_of L) < star_of r"
      by (rule less_r')
  qed
  then show "starfun f x \<approx> star_of L"
    by (unfold approx_def)
qed

lemma NSLIM_LIM:
  assumes f: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L"
  shows "f \<midarrow>a\<rightarrow> L"
proof (rule LIM_I)
  fix r :: real
  assume r: "0 < r"
  have "\<exists>s>0. \<forall>x. x \<noteq> star_of a \<and> hnorm (x - star_of a) < s \<longrightarrow>
    hnorm (starfun f x - star_of L) < star_of r"
  proof (rule exI, safe)
    show "0 < \<epsilon>"
      by (rule epsilon_gt_zero)
  next
    fix x
    assume neq: "x \<noteq> star_of a"
    assume "hnorm (x - star_of a) < \<epsilon>"
    with Infinitesimal_epsilon have "x - star_of a \<in> Infinitesimal"
      by (rule hnorm_less_Infinitesimal)
    then have "x \<approx> star_of a"
      by (unfold approx_def)
    with f neq have "starfun f x \<approx> star_of L"
      by (rule NSLIM_D)
    then have "starfun f x - star_of L \<in> Infinitesimal"
      by (unfold approx_def)
    then show "hnorm (starfun f x - star_of L) < star_of r"
      using r by (rule InfinitesimalD2)
  qed
  then show "\<exists>s>0. \<forall>x. x \<noteq> a \<and> norm (x - a) < s \<longrightarrow> norm (f x - L) < r"
    by transfer
qed

theorem LIM_NSLIM_iff: "f \<midarrow>x\<rightarrow> L \<longleftrightarrow> f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S L"
  by (blast intro: LIM_NSLIM NSLIM_LIM)

subsection \<open>Continuity\<close>

lemma isNSContD: "isNSCont f a \<Longrightarrow> y \<approx> star_of a \<Longrightarrow> ( *f* f) y \<approx> star_of (f a)"
  by (simp add: isNSCont_def)

lemma isNSCont_NSLIM: "isNSCont f a \<Longrightarrow> f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S (f a)"
  by (simp add: isNSCont_def NSLIM_def)

lemma NSLIM_isNSCont: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S (f a) \<Longrightarrow> isNSCont f a"
  by (force simp add: isNSCont_def NSLIM_def)

text \<open>NS continuity can be defined using NS Limit in
  similar fashion to standard definition of continuity.\<close>
lemma isNSCont_NSLIM_iff: "isNSCont f a \<longleftrightarrow> f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S (f a)"
  by (blast intro: isNSCont_NSLIM NSLIM_isNSCont)

text \<open>Hence, NS continuity can be given in terms of standard limit.\<close>
lemma isNSCont_LIM_iff: "(isNSCont f a) = (f \<midarrow>a\<rightarrow> (f a))"
  by (simp add: LIM_NSLIM_iff isNSCont_NSLIM_iff)

text \<open>Moreover, it's trivial now that NS continuity
  is equivalent to standard continuity.\<close>
lemma isNSCont_isCont_iff: "isNSCont f a \<longleftrightarrow> isCont f a"
  by (simp add: isCont_def) (rule isNSCont_LIM_iff)

text \<open>Standard continuity \<open>\<Longrightarrow>\<close> NS continuity.\<close>
lemma isCont_isNSCont: "isCont f a \<Longrightarrow> isNSCont f a"
  by (erule isNSCont_isCont_iff [THEN iffD2])

text \<open>NS continuity \<open>\<Longrightarrow>\<close> Standard continuity.\<close>
lemma isNSCont_isCont: "isNSCont f a \<Longrightarrow> isCont f a"
  by (erule isNSCont_isCont_iff [THEN iffD1])

text \<open>Alternative definition of continuity.\<close>

text \<open>Prove equivalence between NS limits --
  seems easier than using standard definition.\<close>
lemma NSLIM_at0_iff: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L \<longleftrightarrow> (\<lambda>h. f (a + h)) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S L"
proof
  assume "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L"
  then show "(\<lambda>h. f (a + h)) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S L"
    by (simp add: NSLIM_def) (metis (no_types) add_cancel_left_right approx_add_left_iff starfun_lambda_cancel)
next
  assume *: "(\<lambda>h. f (a + h)) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S L"
  show "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L"
  proof (clarsimp simp: NSLIM_def)
    fix x
    assume "x \<noteq> star_of a" "x \<approx> star_of a"
    then have "(*f* (\<lambda>h. f (a + h))) (- star_of a + x) \<approx> star_of L"
      by (metis (no_types, lifting) "*" NSLIM_D add.right_neutral add_minus_cancel approx_minus_iff2 star_zero_def)
    then show "(*f* f) x \<approx> star_of L"
      by (simp add: starfun_lambda_cancel)
  qed
qed

lemma isNSCont_minus: "isNSCont f a \<Longrightarrow> isNSCont (\<lambda>x. - f x) a"
  by (simp add: isNSCont_def)

lemma isNSCont_inverse: "isNSCont f x \<Longrightarrow> f x \<noteq> 0 \<Longrightarrow> isNSCont (\<lambda>x. inverse (f x)) x"
  for f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_div_algebra"
  using NSLIM_inverse NSLIM_isNSCont isNSCont_NSLIM by blast

lemma isNSCont_const [simp]: "isNSCont (\<lambda>x. k) a"
  by (simp add: isNSCont_def)

lemma isNSCont_abs [simp]: "isNSCont abs a"
  for a :: real
  by (auto simp: isNSCont_def intro: approx_hrabs simp: starfun_rabs_hrabs)

subsection \<open>Uniform Continuity\<close>

lemma isNSUContD: "isNSUCont f \<Longrightarrow> x \<approx> y \<Longrightarrow> ( *f* f) x \<approx> ( *f* f) y"
  by (simp add: isNSUCont_def)

lemma isUCont_isNSUCont:
  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
  assumes f: "isUCont f"
  shows "isNSUCont f"
  unfolding isNSUCont_def
proof safe
  fix x y :: "'a star"
  assume approx: "x \<approx> y"
  have "starfun f x - starfun f y \<in> Infinitesimal"
  proof (rule InfinitesimalI2)
    fix r :: real
    assume r: "0 < r"
    with f obtain s where s: "0 < s"
      and less_r: "\<And>x y. norm (x - y) < s \<Longrightarrow> norm (f x - f y) < r"
      by (auto simp add: isUCont_def dist_norm)
    from less_r have less_r':
      "\<And>x y. hnorm (x - y) < star_of s \<Longrightarrow> hnorm (starfun f x - starfun f y) < star_of r"
      by transfer
    from approx have "x - y \<in> Infinitesimal"
      by (unfold approx_def)
    then have "hnorm (x - y) < star_of s"
      using s by (rule InfinitesimalD2)
    then show "hnorm (starfun f x - starfun f y) < star_of r"
      by (rule less_r')
  qed
  then show "starfun f x \<approx> starfun f y"
    by (unfold approx_def)
qed

lemma isNSUCont_isUCont:
  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
  assumes f: "isNSUCont f"
  shows "isUCont f"
  unfolding isUCont_def dist_norm
proof safe
  fix r :: real
  assume r: "0 < r"
  have "\<exists>s>0. \<forall>x y. hnorm (x - y) < s \<longrightarrow> hnorm (starfun f x - starfun f y) < star_of r"
  proof (rule exI, safe)
    show "0 < \<epsilon>"
      by (rule epsilon_gt_zero)
  next
    fix x y :: "'a star"
    assume "hnorm (x - y) < \<epsilon>"
    with Infinitesimal_epsilon have "x - y \<in> Infinitesimal"
      by (rule hnorm_less_Infinitesimal)
    then have "x \<approx> y"
      by (unfold approx_def)
    with f have "starfun f x \<approx> starfun f y"
      by (simp add: isNSUCont_def)
    then have "starfun f x - starfun f y \<in> Infinitesimal"
      by (unfold approx_def)
    then show "hnorm (starfun f x - starfun f y) < star_of r"
      using r by (rule InfinitesimalD2)
  qed
  then show "\<exists>s>0. \<forall>x y. norm (x - y) < s \<longrightarrow> norm (f x - f y) < r"
    by transfer
qed

end


(*
  File:    Linear_Recurrences_Solver.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Solver for linear recurrences\<close>
theory Linear_Recurrences_Solver
imports
  Complex_Main
  Linear_Recurrences.Linear_Homogenous_Recurrences
  Linear_Recurrences.Linear_Inhomogenous_Recurrences
  Factor_Algebraic_Polynomial.Factor_Complex_Poly
begin

lemma is_factorization_of_factor_complex_main:
  assumes "factor_complex_main p = fctrs"
  shows   "is_factorization_of fctrs p"
  unfolding is_factorization_of_def
proof safe
  from assms have "p = Polynomial.smult (fst fctrs) (\<Prod>(x, i)\<leftarrow>snd fctrs. [:- x, 1:] ^ Suc i)"
    by (intro factor_complex_main) simp_all
  also have "\<dots> = interp_factorization fctrs"
    by (simp add: interp_factorization_def case_prod_unfold)
  finally show "interp_factorization fctrs = p" ..
  show "distinct (map fst (snd fctrs))" unfolding assms[symmetric]
    by (rule distinct_factor_complex_main)
qed

definition solve_ratfps
    :: "complex ratfps \<Rightarrow> complex poly \<times> (complex poly \<times> complex) list" where
  "solve_ratfps f =
     (case quot_of_ratfps f of (p, q) \<Rightarrow>
        solve_factored_ratfps' p (factor_complex_main (reflect_poly q)))"

lemma solve_ratfps:
  assumes "solve_ratfps f = sol"
  shows   "Abs_fps (interp_ratfps_solution sol) = fps_of_ratfps f"
proof -
  define p and q where "p = fst (quot_of_ratfps f)" and "q = snd (quot_of_ratfps f)"
  with assms obtain fctrs where fctrs: "factor_complex_main (reflect_poly q) = fctrs"
    by (auto simp: solve_ratfps_def p_def q_def case_prod_unfold split: if_splits)
  have q: "coeff q 0 \<noteq> 0" by (simp add: q_def)
  hence [simp]: "q \<noteq> 0" by auto
  from fctrs have "is_factorization_of fctrs (reflect_poly q)"
    by (rule is_factorization_of_factor_complex_main)
  with assms have "is_alt_factorization_of fctrs (reflect_poly (reflect_poly q))"
    by (intro reflect_factorization) simp_all
  hence "is_alt_factorization_of fctrs q" by (simp add: q)
  with fctrs q
    have "Abs_fps (interp_ratfps_solution (solve_factored_ratfps' p fctrs)) =
            fps_of_poly p / fps_of_poly q"
    by (intro solve_factored_ratfps') (simp_all)
  also from fctrs assms have "solve_factored_ratfps' p fctrs = sol"
    by (simp add: solve_ratfps_def p_def q_def case_prod_unfold split: if_splits)
  finally show ?thesis by (simp add: fps_of_ratfps_altdef case_prod_unfold p_def q_def)
qed

definition solve_lhr
    :: "complex list \<Rightarrow> complex list \<Rightarrow> (complex poly \<times> (complex poly \<times> complex) list) option" where
  "solve_lhr cs fs = (if cs = [] \<or> length fs < length cs - 1 then None else
     let m = length fs + 1 - length cs;
         p = lhr_fps_numerator m cs (\<lambda>n. fs ! n);
         q = lr_fps_denominator' cs
     in  Some (solve_factored_ratfps' p (factor_complex_main q)))"

lemma solve_lhr:
  assumes "linear_homogenous_recurrence f cs fs"
  assumes "Some sol = solve_lhr cs fs"
  shows   "f = interp_ratfps_solution sol"
proof -
  obtain fctrs where
      fctrs: "factor_complex_main (lr_fps_denominator' cs) = fctrs"
    by auto
  from is_factorization_of_factor_complex_main[OF this]
    have factorization: "is_factorization_of fctrs (lr_fps_denominator' cs)" .

  have "f = interp_ratfps_solution (solve_factored_ratfps' (lhr_fps_numerator
              (length fs + 1 - length cs) cs ((!) fs)) fctrs)"
    (is "_ = interp_ratfps_solution ?sol") by (intro solve_lhr_aux) fact+
  also from assms(2) have "?sol = sol"
    by (auto simp: solve_lhr_def Let_def case_prod_unfold fctrs split: if_splits)
  finally show ?thesis .
qed

definition solve_lir
    :: "complex list \<Rightarrow> complex list \<Rightarrow> complex polyexp \<Rightarrow>
          (complex poly \<times> (complex poly \<times> complex) list) option" where
  "solve_lir cs fs g = map_option solve_ratfps (lir_fps cs fs g)"

lemma solve_lir:
  assumes "linear_inhomogenous_recurrence f (eval_polyexp g) cs fs"
  assumes "solve_lir cs fs g = Some sol"
  shows   "f = interp_ratfps_solution sol"
proof -
  from lir_fps_correct[OF assms(1)] obtain fps
    where fps: "lir_fps cs fs g = Some fps" "fps_of_ratfps fps = Abs_fps f" by blast
  from assms(2) have "solve_ratfps fps = sol"
    by (simp add: solve_lir_def fps case_prod_unfold)
  from solve_ratfps[OF this] have "Abs_fps (interp_ratfps_solution sol) = fps_of_ratfps fps"
    by (simp add: case_prod_unfold fps_of_ratfps_altdef)
  with fps have "Abs_fps f = Abs_fps (interp_ratfps_solution sol)" by simp
  thus ?thesis by (simp add: fun_eq_iff fps_eq_iff)
qed

end


(* Title:      Finite Suprema
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Finite Suprema\<close>

theory Finite_Suprema
imports Dioid
begin

text \<open>This file contains an adaptation of Isabelle's library for
finite sums to the case of (join) semilattices and dioids. In this
setting, addition is idempotent; finite sums are finite suprema.

We add some basic properties of finite suprema for (join) semilattices
and dioids.\<close>

subsection \<open>Auxiliary Lemmas\<close>

lemma fun_im: "{f a |a. a \<in> A} = {b. b \<in> f ` A}"
  by auto

lemma fset_to_im: "{f x |x. x \<in> X} = f ` X"
  by auto

lemma cart_flip_aux: "{f (snd p) (fst p) |p. p \<in> (B \<times> A)} = {f (fst p) (snd p) |p. p \<in> (A \<times> B)}"
  by auto

lemma cart_flip: "(\<lambda>p. f (snd p) (fst p)) ` (B \<times> A) = (\<lambda>p. f (fst p) (snd p)) ` (A \<times> B)"
  by (metis cart_flip_aux fset_to_im)

lemma fprod_aux: "{x \<cdot> y |x y. x \<in> (f ` A) \<and> y \<in> (g ` B)} = {f x \<cdot> g y |x y. x \<in> A \<and> y \<in> B}"
  by auto

subsection \<open>Finite Suprema in Semilattices\<close>

text \<open>The first lemma shows that, in the context of semilattices,
finite sums satisfy the defining property of finite suprema.\<close>

lemma sum_sup:
  assumes "finite (A :: 'a::join_semilattice_zero set)"
  shows "\<Sum>A \<le> z \<longleftrightarrow> (\<forall>a \<in> A. a \<le> z)"
proof (induct rule: finite_induct[OF assms])
  fix z ::'a
  show "(\<Sum>{} \<le> z) = (\<forall>a \<in> {}. a \<le> z)"
    by simp
next
  fix x z :: 'a and F :: "'a set"
  assume finF: "finite F"
    and xnF: "x \<notin> F"
    and indhyp: "(\<Sum>F \<le> z) = (\<forall>a \<in> F. a \<le> z)"
  show "(\<Sum>(insert x F) \<le> z) = (\<forall>a \<in> insert x F. a \<le> z)"
  proof -
    have "\<Sum>(insert x F) \<le> z \<longleftrightarrow> (x + \<Sum>F) \<le> z"
      by (metis finF sum.insert xnF)
    also have "... \<longleftrightarrow> x \<le> z \<and> \<Sum>F \<le> z"
      by simp
    also have "... \<longleftrightarrow> x \<le> z \<and> (\<forall>a \<in> F. a \<le> z)"
      by (metis (lifting) indhyp)
    also have "... \<longleftrightarrow> (\<forall>a \<in> insert x F. a \<le> z)"
      by (metis insert_iff)
    ultimately show "(\<Sum>(insert x F) \<le> z) = (\<forall>a \<in> insert x F. a \<le> z)"
      by blast
  qed
qed

text \<open>This immediately implies some variants.\<close>

lemma sum_less_eqI:
  "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> y) \<Longrightarrow> sum f A \<le> (y::'a::join_semilattice_zero)"
 apply (atomize (full))
 apply (case_tac "finite A")
  apply (erule finite_induct)
   apply simp_all
done

lemma sum_less_eqE:
  "\<lbrakk> sum f A \<le> y; x \<in> A; finite A \<rbrakk> \<Longrightarrow> f x \<le> (y::'a::join_semilattice_zero)"
 apply (erule rev_mp)
 apply (erule rev_mp)
 apply (erule finite_induct)
  apply auto
done

lemma sum_fun_image_sup:
  fixes f :: "'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A :: 'a set)"
  shows "\<Sum>(f ` A) \<le> z \<longleftrightarrow> (\<forall>a \<in> A. f a \<le> z)"
  by (simp add: assms sum_sup)

lemma sum_fun_sup:
  fixes f :: "'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A ::'a set)"
  shows "\<Sum>{f a | a. a \<in> A} \<le> z \<longleftrightarrow> (\<forall>a \<in> A. f a \<le> z)"
  by (simp only: fset_to_im assms sum_fun_image_sup)

lemma sum_intro:
  assumes "finite (A :: 'a::join_semilattice_zero set)" and "finite B"
  shows "(\<forall>a \<in> A. \<exists>b \<in> B. a \<le> b) \<longrightarrow> (\<Sum>A \<le> \<Sum>B)"
  by (metis assms order_refl order_trans sum_sup)

text \<open>Next we prove an additivity property for suprema.\<close>

lemma sum_union:
  assumes "finite (A :: 'a::join_semilattice_zero set)"
  and "finite (B :: 'a::join_semilattice_zero set)"
  shows "\<Sum>(A \<union> B) = \<Sum>A + \<Sum>B"
proof -
    have "\<forall>z. \<Sum>(A \<union> B) \<le> z \<longleftrightarrow> (\<Sum>A + \<Sum>B \<le> z)"
      by (auto simp add: assms sum_sup)
  thus ?thesis
    by (simp add: eq_iff)
qed

text \<open>It follows that the sum (supremum) of a two-element set is the
join of its elements.\<close>

lemma sum_bin[simp]: "\<Sum>{(x :: 'a::join_semilattice_zero),y} = x + y"
  by (subst insert_is_Un, subst sum_union, auto)

text \<open>Next we show that finite suprema are order preserving.\<close>

lemma sum_iso:
  assumes "finite (B :: 'a::join_semilattice_zero set)"
  shows "A \<subseteq> B \<longrightarrow> \<Sum> A \<le> \<Sum> B"
  by (metis assms finite_subset order_refl rev_subsetD sum_sup)

text \<open>The following lemmas state unfold properties for suprema and
finite sets. They are subtly different from the non-idempotent case,
where additional side conditions are required.\<close>

lemma sum_insert [simp]:
  assumes "finite (A :: 'a::join_semilattice_zero set)"
  shows "\<Sum>(insert x A) = x + \<Sum>A"
proof -
  have "\<Sum>(insert x A) = \<Sum>{x} + \<Sum>A"
    by (metis insert_is_Un assms finite.emptyI finite.insertI sum_union)
  thus ?thesis
    by auto
qed

lemma sum_fun_insert:
  fixes f :: "'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A :: 'a set)"
  shows "\<Sum>(f ` (insert x A)) = f x + \<Sum>(f ` A)"
  by (simp add: assms)

text \<open>Now we show that set comprehensions with nested suprema can
be flattened.\<close>

lemma flatten1_im:
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A :: 'a set)"
  and "finite (B :: 'a set)"
  shows "\<Sum>((\<lambda>x. \<Sum>(f x ` B)) ` A) = \<Sum>((\<lambda>p. f (fst p) (snd p)) ` (A \<times> B))"
proof -
  have "\<forall>z. \<Sum>((\<lambda>x. \<Sum>(f x ` B)) ` A) \<le> z \<longleftrightarrow> \<Sum>((\<lambda>p. f (fst p) (snd p)) ` (A \<times> B)) \<le> z"
    by (simp add: assms finite_cartesian_product sum_fun_image_sup)
  thus ?thesis
    by (simp add: eq_iff)
qed

lemma flatten2_im:
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A ::'a set)"
  and "finite (B ::'a set)"
  shows "\<Sum>((\<lambda>y. \<Sum> ((\<lambda>x. f x y) ` A)) ` B) = \<Sum>((\<lambda>p. f (fst p) (snd p)) ` (A \<times> B))"
  by (simp only: flatten1_im assms cart_flip)

lemma sum_flatten1:
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (A :: 'a set)"
  and "finite (B :: 'a set)"
  shows "\<Sum>{\<Sum>{f x y |y. y \<in> B} |x. x \<in> A} = \<Sum>{f x y |x y. x \<in> A \<and> y \<in> B}"
 apply (simp add: fset_to_im assms flatten1_im)
 apply (subst fset_to_im[symmetric])
 apply simp
done

lemma sum_flatten2:
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite A"
  and "finite B"
  shows "\<Sum>{\<Sum> {f x y |x. x \<in> A} |y. y \<in> B} = \<Sum>{f x y |x y. x \<in> A \<and> y \<in> B}"
 apply (simp add: fset_to_im assms flatten2_im)
 apply (subst fset_to_im[symmetric])
 apply simp
done

text \<open>Next we show another additivity property for suprema.\<close>

lemma sum_fun_sum:
  fixes f g :: "'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes  "finite (A :: 'a set)"
  shows "\<Sum>((\<lambda>x. f x + g x) ` A) = \<Sum>(f ` A) + \<Sum>(g ` A)"
proof -
  {
    fix z:: 'b
    have "\<Sum>((\<lambda>x. f x + g x) ` A) \<le> z \<longleftrightarrow> \<Sum>(f ` A) + \<Sum>(g ` A) \<le> z"
      by (auto simp add: assms sum_fun_image_sup)
  }
  thus ?thesis
    by (simp add: eq_iff)
qed

text \<open>The last lemma of this section prepares the distributivity
  laws that hold for dioids. It states that a strict additive function
  distributes over finite suprema, which is a continuity property in
  the finite.\<close>

lemma sum_fun_add:
  fixes f :: "'a::join_semilattice_zero \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite (X :: 'a set)"
  and fstrict: "f 0 = 0"
  and fadd: "\<And>x y. f (x + y) = f x + f y"
  shows "f (\<Sum> X) = \<Sum>(f ` X)"
proof (induct rule: finite_induct[OF assms(1)])
  show "f (\<Sum>{}) = \<Sum>(f ` {})"
    by (metis fstrict image_empty sum.empty)
  fix x :: 'a and  F ::" 'a set"
  assume finF: "finite F"
    and indhyp: "f (\<Sum>F) = \<Sum>(f ` F)"
  have "f (\<Sum>(insert x F)) = f (x + \<Sum>F)"
    by (metis sum_insert finF)
  also have "... = f x + (f (\<Sum>F))"
    by (rule fadd)
  also have "... = f x + \<Sum>(f ` F)"
    by (metis indhyp)
  also have "... = \<Sum>(f ` (insert x F))"
    by (metis finF sum_fun_insert)
  finally show "f (\<Sum>(insert x F)) = \<Sum>(f ` insert x F)" .
qed

subsection \<open>Finite Suprema in Dioids\<close>

text \<open>In this section we mainly prove variants of distributivity laws.\<close>

lemma sum_distl:
  assumes "finite Y"
  shows "(x :: 'a::dioid_one_zero) \<cdot> (\<Sum>Y) = \<Sum>{x \<cdot> y|y. y \<in> Y}"
  by (simp only: sum_fun_add assms annir distrib_left Collect_mem_eq fun_im)

lemma sum_distr:
  assumes "finite X"
  shows "(\<Sum>X) \<cdot> (y :: 'a::dioid_one_zero) = \<Sum>{x \<cdot> y|x. x \<in> X}"
proof -
  have "(\<Sum> X) \<cdot> y = \<Sum> ((\<lambda>x. x \<cdot> y) ` X)"
    by (rule sum_fun_add, metis assms, rule annil, rule distrib_right)
  thus ?thesis
    by (metis Collect_mem_eq fun_im)
qed

lemma sum_fun_distl:
  fixes f :: "'a \<Rightarrow> 'b::dioid_one_zero"
  assumes "finite (Y :: 'a set)"
  shows "x \<cdot> \<Sum>(f ` Y) = \<Sum>{x \<cdot> f y |y. y \<in> Y}"
  by (simp add: assms fun_im image_image sum_distl)

lemma sum_fun_distr:
  fixes f :: "'a \<Rightarrow> 'b::dioid_one_zero"
  assumes "finite (X :: 'a set)"
  shows "\<Sum>(f ` X) \<cdot> y = \<Sum>{f x \<cdot> y |x. x \<in> X}"
  by (simp add: assms fun_im image_image sum_distr)

lemma sum_distl_flat:
  assumes "finite (X ::'a::dioid_one_zero set)"
  and "finite Y"
  shows "\<Sum>{x \<cdot> \<Sum>Y |x. x \<in> X} = \<Sum>{x \<cdot> y|x y. x \<in> X \<and> y \<in> Y}"
  by (simp only: assms sum_distl sum_flatten1)

lemma sum_distr_flat:
  assumes "finite X"
  and "finite (Y :: 'a::dioid_one_zero set)"
  shows "\<Sum>{(\<Sum>X) \<cdot> y |y. y \<in> Y} = \<Sum>{x \<cdot> y|x y. x \<in> X \<and> y \<in> Y}"
  by (simp only: assms sum_distr sum_flatten2)

lemma sum_sum_distl:
  assumes "finite (X :: 'a::dioid_one_zero set)"
  and "finite Y"
  shows "\<Sum>((\<lambda>x. x \<cdot> (\<Sum>Y)) ` X) = \<Sum>{x \<cdot> y |x y. x \<in> X \<and> y \<in> Y}"
proof -
  have "\<Sum>((\<lambda>x. x \<cdot> (\<Sum>Y)) ` X) = \<Sum>{\<Sum>{x \<cdot> y |y. y \<in> Y} |x. x \<in> X}"
    by (auto simp add: sum_distl assms fset_to_im)
  thus ?thesis
    by (simp add: assms sum_flatten1)
qed

lemma sum_sum_distr:
  assumes "finite X"
  and "finite Y"
  shows "\<Sum>((\<lambda>y. (\<Sum>X) \<cdot> (y :: 'a::dioid_one_zero)) ` Y) = \<Sum>{x \<cdot> y|x y. x \<in> X \<and> y \<in> Y}"
proof -
  have "\<Sum>((\<lambda>y. (\<Sum>X) \<cdot> y) ` Y) = \<Sum>{\<Sum>{x \<cdot> y |x. x \<in> X} |y. y \<in> Y}"
    by (auto simp add: sum_distr assms fset_to_im)
  thus ?thesis
    by (simp add: assms sum_flatten2)
qed

lemma sum_sum_distl_fun:
  fixes f g :: "'a \<Rightarrow> 'b::dioid_one_zero"
  fixes h :: "'a \<Rightarrow> 'a set"
  assumes "\<And>x. finite (h x)"
  and "finite X"
  shows "\<Sum>((\<lambda>x. f x \<cdot> \<Sum>(g ` h x)) ` X) = \<Sum>{\<Sum> {f x \<cdot> g y |y. y \<in> h x} |x. x \<in> X}"
  by (auto simp add: sum_fun_distl assms fset_to_im)

lemma sum_sum_distr_fun:
  fixes f g :: "'a \<Rightarrow> 'b::dioid_one_zero"
  fixes h :: "'a \<Rightarrow> 'a set"
  assumes "finite Y"
  and "\<And>y. finite (h y)"
  shows "\<Sum>((\<lambda>y. \<Sum>(f ` h y) \<cdot> g y) ` Y) = \<Sum>{\<Sum>{f x \<cdot> g y |x. x \<in> (h y)} |y. y \<in> Y}"
  by (auto simp add: sum_fun_distr assms fset_to_im)

lemma sum_dist:
  assumes "finite (A :: 'a::dioid_one_zero set)"
  and "finite B"
  shows "(\<Sum>A) \<cdot> (\<Sum>B) = \<Sum>{x \<cdot> y |x y. x \<in> A \<and> y \<in> B}"
proof -
  have "(\<Sum>A) \<cdot> (\<Sum>B) = \<Sum>{x \<cdot> \<Sum>B |x. x \<in> A}"
    by (simp add: assms sum_distr)
  also have "... = \<Sum>{\<Sum>{x \<cdot> y |y. y \<in> B} |x. x \<in> A}"
    by (simp add: assms sum_distl)
  finally show ?thesis
    by  (simp only: sum_flatten1 assms finite_cartesian_product)
qed

lemma dioid_sum_prod_var:
  fixes f g :: "'a \<Rightarrow> 'b::dioid_one_zero"
  assumes "finite (A ::'a set)"
  shows "(\<Sum>(f ` A)) \<cdot> (\<Sum> (g ` A)) = \<Sum>{f x \<cdot> g y |x y. x \<in> A \<and> y \<in> A}"
  by (simp add: assms sum_dist fprod_aux)

lemma dioid_sum_prod:
  fixes f g :: "'a \<Rightarrow> 'b::dioid_one_zero"
  assumes "finite (A :: 'a set)"
  shows "(\<Sum>{f x |x. x \<in> A}) \<cdot> (\<Sum>{g x |x. x \<in> A}) = \<Sum>{f x \<cdot> g y |x y. x \<in> A \<and> y \<in> A}"
  by (simp add: assms dioid_sum_prod_var fset_to_im)

lemma sum_image:
  fixes f :: "'a \<Rightarrow> 'b::join_semilattice_zero"
  assumes "finite X"
  shows "sum f X = \<Sum>(f ` X)"
using assms
proof (induct rule: finite_induct)
  case empty thus ?case by simp
next
  case insert thus ?case
    by (metis sum.insert sum_fun_insert)
qed

lemma sum_interval_cong:
  "\<lbrakk> \<And> i. \<lbrakk> m \<le> i; i \<le> n \<rbrakk> \<Longrightarrow> P(i) = Q(i) \<rbrakk> \<Longrightarrow> (\<Sum>i=m..n. P(i)) = (\<Sum>i=m..n. Q(i))"
  by (auto intro: sum.cong)

lemma sum_interval_distl:
  fixes f :: "nat \<Rightarrow> 'a::dioid_one_zero"
  assumes "m \<le> n"
  shows "x \<cdot> (\<Sum>i=m..n. f(i)) = (\<Sum>i=m..n. (x \<cdot> f(i)))"
proof -
  have "x \<cdot> (\<Sum>i=m..n. f(i)) = x \<cdot> \<Sum>(f ` {m..n})"
    by (metis finite_atLeastAtMost sum_image)
  also have "... = \<Sum>{x \<cdot> y |y. y \<in> f ` {m..n}}"
    by (metis finite_atLeastAtMost fset_to_im image_image sum_fun_distl)
  also have "... = \<Sum>((\<lambda>i. x \<cdot> f i) ` {m..n})"
    by (metis fset_to_im image_image)
  also have "... = (\<Sum>i=m..n. (x \<cdot> f(i)))"
    by (metis finite_atLeastAtMost sum_image)
  finally show ?thesis .
qed

lemma sum_interval_distr:
  fixes f :: "nat \<Rightarrow> 'a::dioid_one_zero"
  assumes "m \<le> n"
  shows "(\<Sum>i=m..n. f(i)) \<cdot> y = (\<Sum>i=m..n. (f(i) \<cdot> y))"
  proof -
  have "(\<Sum>i=m..n. f(i)) \<cdot> y = \<Sum>(f ` {m..n}) \<cdot> y"
    by (metis finite_atLeastAtMost sum_image)
  also have "... = \<Sum>{x \<cdot> y |x. x \<in> f ` {m..n}}"
    by (metis calculation finite_atLeastAtMost finite_imageI fset_to_im sum_distr)
  also have "... = \<Sum>((\<lambda>i. f(i) \<cdot> y) ` {m..n})"
    by (auto intro: sum.cong)
  also have "... = (\<Sum>i=m..n. (f(i) \<cdot> y))"
    by (metis finite_atLeastAtMost sum_image)
  finally show ?thesis .
qed

text \<open>There are interesting theorems for finite sums in Kleene
algebras; we leave them for future consideration.\<close>

end