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

section \<open>Cartesian Products as Vector Spaces\<close>

theory Product_Vector
  imports
    Complex_Main
    "HOL-Library.Product_Plus"
begin

lemma Times_eq_image_sum:
  fixes S :: "'a :: comm_monoid_add set" and T :: "'b :: comm_monoid_add set"
  shows "S \<times> T = {u + v |u v. u \<in> (\<lambda>x. (x, 0)) ` S \<and> v \<in> Pair 0 ` T}"
  by force

subsection \<open>Product is a Module\<close>

locale module_prod = module_pair begin

definition scale :: "'a \<Rightarrow> 'b \<times> 'c \<Rightarrow> 'b \<times> 'c"
  where "scale a v = (s1 a (fst v), s2 a (snd v))"

lemma\<^marker>\<open>tag important\<close> scale_prod: "scale x (a, b) = (s1 x a, s2 x b)"
  by (auto simp: scale_def)

sublocale\<^marker>\<open>tag important\<close> p: module scale
proof qed (simp_all add: scale_def
  m1.scale_left_distrib m1.scale_right_distrib m2.scale_left_distrib m2.scale_right_distrib)

lemma subspace_Times: "m1.subspace A \<Longrightarrow> m2.subspace B \<Longrightarrow> p.subspace (A \<times> B)"
  unfolding m1.subspace_def m2.subspace_def p.subspace_def
  by (auto simp: zero_prod_def scale_def)

lemma module_hom_fst: "module_hom scale s1 fst"
  by unfold_locales (auto simp: scale_def)

lemma module_hom_snd: "module_hom scale s2 snd"
  by unfold_locales (auto simp: scale_def)

end

locale vector_space_prod = vector_space_pair begin

sublocale module_prod s1 s2
  rewrites "module_hom = Vector_Spaces.linear"
  by unfold_locales (fact module_hom_eq_linear)

sublocale p: vector_space scale by unfold_locales (auto simp: algebra_simps)

lemmas linear_fst = module_hom_fst
  and linear_snd = module_hom_snd

end

subsection \<open>Product is a Real Vector Space\<close>

instantiation prod :: (real_vector, real_vector) real_vector
begin

definition scaleR_prod_def:
  "scaleR r A = (scaleR r (fst A), scaleR r (snd A))"

lemma fst_scaleR [simp]: "fst (scaleR r A) = scaleR r (fst A)"
  unfolding scaleR_prod_def by simp

lemma snd_scaleR [simp]: "snd (scaleR r A) = scaleR r (snd A)"
  unfolding scaleR_prod_def by simp

proposition scaleR_Pair [simp]: "scaleR r (a, b) = (scaleR r a, scaleR r b)"
  unfolding scaleR_prod_def by simp

instance
proof
  fix a b :: real and x y :: "'a \<times> 'b"
  show "scaleR a (x + y) = scaleR a x + scaleR a y"
    by (simp add: prod_eq_iff scaleR_right_distrib)
  show "scaleR (a + b) x = scaleR a x + scaleR b x"
    by (simp add: prod_eq_iff scaleR_left_distrib)
  show "scaleR a (scaleR b x) = scaleR (a * b) x"
    by (simp add: prod_eq_iff)
  show "scaleR 1 x = x"
    by (simp add: prod_eq_iff)
qed

end

lemma module_prod_scale_eq_scaleR: "module_prod.scale (*\<^sub>R) (*\<^sub>R) = scaleR"
  apply (rule ext) apply (rule ext)
  apply (subst module_prod.scale_def)
  subgoal by unfold_locales
  by (simp add: scaleR_prod_def)

interpretation real_vector?: vector_space_prod "scaleR::_\<Rightarrow>_\<Rightarrow>'a::real_vector" "scaleR::_\<Rightarrow>_\<Rightarrow>'b::real_vector"
  rewrites "scale = ((*\<^sub>R)::_\<Rightarrow>_\<Rightarrow>('a \<times> 'b))"
    and "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"
  subgoal by unfold_locales
  subgoal by (fact module_prod_scale_eq_scaleR)
  unfolding dependent_raw_def representation_raw_def subspace_raw_def span_raw_def
    extend_basis_raw_def dim_raw_def linear_def
  by (rule refl)+

subsection \<open>Product is a Metric Space\<close>

(* TODO: Product of uniform spaces and compatibility with metric_spaces! *)

instantiation\<^marker>\<open>tag unimportant\<close> prod :: (metric_space, metric_space) dist
begin

definition dist_prod_def[code del]:
  "dist x y = sqrt ((dist (fst x) (fst y))\<^sup>2 + (dist (snd x) (snd y))\<^sup>2)"

instance ..
end

instantiation\<^marker>\<open>tag unimportant\<close> prod :: (metric_space, metric_space) uniformity_dist
begin

definition [code del]:
  "(uniformity :: (('a \<times> 'b) \<times> ('a \<times> 'b)) filter) =
    (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"

instance
  by standard (rule uniformity_prod_def)
end

declare uniformity_Abort[where 'a="'a :: metric_space \<times> 'b :: metric_space", code]

instantiation prod :: (metric_space, metric_space) metric_space
begin

proposition dist_Pair_Pair: "dist (a, b) (c, d) = sqrt ((dist a c)\<^sup>2 + (dist b d)\<^sup>2)"
  unfolding dist_prod_def by simp

lemma dist_fst_le: "dist (fst x) (fst y) \<le> dist x y"
  unfolding dist_prod_def by (rule real_sqrt_sum_squares_ge1)

lemma dist_snd_le: "dist (snd x) (snd y) \<le> dist x y"
  unfolding dist_prod_def by (rule real_sqrt_sum_squares_ge2)

instance
proof
  fix x y :: "'a \<times> 'b"
  show "dist x y = 0 \<longleftrightarrow> x = y"
    unfolding dist_prod_def prod_eq_iff by simp
next
  fix x y z :: "'a \<times> 'b"
  show "dist x y \<le> dist x z + dist y z"
    unfolding dist_prod_def
    by (intro order_trans [OF _ real_sqrt_sum_squares_triangle_ineq]
        real_sqrt_le_mono add_mono power_mono dist_triangle2 zero_le_dist)
next
  fix S :: "('a \<times> 'b) set"
  have *: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"
  proof
    assume "open S" show "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S"
    proof
      fix x assume "x \<in> S"
      obtain A B where "open A" "open B" "x \<in> A \<times> B" "A \<times> B \<subseteq> S"
        using \<open>open S\<close> and \<open>x \<in> S\<close> by (rule open_prod_elim)
      obtain r where r: "0 < r" "\<forall>y. dist y (fst x) < r \<longrightarrow> y \<in> A"
        using \<open>open A\<close> and \<open>x \<in> A \<times> B\<close> unfolding open_dist by auto
      obtain s where s: "0 < s" "\<forall>y. dist y (snd x) < s \<longrightarrow> y \<in> B"
        using \<open>open B\<close> and \<open>x \<in> A \<times> B\<close> unfolding open_dist by auto
      let ?e = "min r s"
      have "0 < ?e \<and> (\<forall>y. dist y x < ?e \<longrightarrow> y \<in> S)"
      proof (intro allI impI conjI)
        show "0 < min r s" by (simp add: r(1) s(1))
      next
        fix y assume "dist y x < min r s"
        hence "dist y x < r" and "dist y x < s"
          by simp_all
        hence "dist (fst y) (fst x) < r" and "dist (snd y) (snd x) < s"
          by (auto intro: le_less_trans dist_fst_le dist_snd_le)
        hence "fst y \<in> A" and "snd y \<in> B"
          by (simp_all add: r(2) s(2))
        hence "y \<in> A \<times> B" by (induct y, simp)
        with \<open>A \<times> B \<subseteq> S\<close> show "y \<in> S" ..
      qed
      thus "\<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S" ..
    qed
  next
    assume *: "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S" show "open S"
    proof (rule open_prod_intro)
      fix x assume "x \<in> S"
      then obtain e where "0 < e" and S: "\<forall>y. dist y x < e \<longrightarrow> y \<in> S"
        using * by fast
      define r where "r = e / sqrt 2"
      define s where "s = e / sqrt 2"
      from \<open>0 < e\<close> have "0 < r" and "0 < s"
        unfolding r_def s_def by simp_all
      from \<open>0 < e\<close> have "e = sqrt (r\<^sup>2 + s\<^sup>2)"
        unfolding r_def s_def by (simp add: power_divide)
      define A where "A = {y. dist (fst x) y < r}"
      define B where "B = {y. dist (snd x) y < s}"
      have "open A" and "open B"
        unfolding A_def B_def by (simp_all add: open_ball)
      moreover have "x \<in> A \<times> B"
        unfolding A_def B_def mem_Times_iff
        using \<open>0 < r\<close> and \<open>0 < s\<close> by simp
      moreover have "A \<times> B \<subseteq> S"
      proof (clarify)
        fix a b assume "a \<in> A" and "b \<in> B"
        hence "dist a (fst x) < r" and "dist b (snd x) < s"
          unfolding A_def B_def by (simp_all add: dist_commute)
        hence "dist (a, b) x < e"
          unfolding dist_prod_def \<open>e = sqrt (r\<^sup>2 + s\<^sup>2)\<close>
          by (simp add: add_strict_mono power_strict_mono)
        thus "(a, b) \<in> S"
          by (simp add: S)
      qed
      ultimately show "\<exists>A B. open A \<and> open B \<and> x \<in> A \<times> B \<and> A \<times> B \<subseteq> S" by fast
    qed
  qed
  show "open S = (\<forall>x\<in>S. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> S)"
    unfolding * eventually_uniformity_metric
    by (simp del: split_paired_All add: dist_prod_def dist_commute)
qed

end

declare [[code abort: "dist::('a::metric_space*'b::metric_space)\<Rightarrow>('a*'b) \<Rightarrow> real"]]

lemma Cauchy_fst: "Cauchy X \<Longrightarrow> Cauchy (\<lambda>n. fst (X n))"
  unfolding Cauchy_def by (fast elim: le_less_trans [OF dist_fst_le])

lemma Cauchy_snd: "Cauchy X \<Longrightarrow> Cauchy (\<lambda>n. snd (X n))"
  unfolding Cauchy_def by (fast elim: le_less_trans [OF dist_snd_le])

lemma Cauchy_Pair:
  assumes "Cauchy X" and "Cauchy Y"
  shows "Cauchy (\<lambda>n. (X n, Y n))"
proof (rule metric_CauchyI)
  fix r :: real assume "0 < r"
  hence "0 < r / sqrt 2" (is "0 < ?s") by simp
  obtain M where M: "\<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < ?s"
    using metric_CauchyD [OF \<open>Cauchy X\<close> \<open>0 < ?s\<close>] ..
  obtain N where N: "\<forall>m\<ge>N. \<forall>n\<ge>N. dist (Y m) (Y n) < ?s"
    using metric_CauchyD [OF \<open>Cauchy Y\<close> \<open>0 < ?s\<close>] ..
  have "\<forall>m\<ge>max M N. \<forall>n\<ge>max M N. dist (X m, Y m) (X n, Y n) < r"
    using M N by (simp add: real_sqrt_sum_squares_less dist_Pair_Pair)
  then show "\<exists>n0. \<forall>m\<ge>n0. \<forall>n\<ge>n0. dist (X m, Y m) (X n, Y n) < r" ..
qed

subsection \<open>Product is a Complete Metric Space\<close>

instance\<^marker>\<open>tag important\<close> prod :: (complete_space, complete_space) complete_space
proof
  fix X :: "nat \<Rightarrow> 'a \<times> 'b" assume "Cauchy X"
  have 1: "(\<lambda>n. fst (X n)) \<longlonglongrightarrow> lim (\<lambda>n. fst (X n))"
    using Cauchy_fst [OF \<open>Cauchy X\<close>]
    by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
  have 2: "(\<lambda>n. snd (X n)) \<longlonglongrightarrow> lim (\<lambda>n. snd (X n))"
    using Cauchy_snd [OF \<open>Cauchy X\<close>]
    by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
  have "X \<longlonglongrightarrow> (lim (\<lambda>n. fst (X n)), lim (\<lambda>n. snd (X n)))"
    using tendsto_Pair [OF 1 2] by simp
  then show "convergent X"
    by (rule convergentI)
qed

subsection \<open>Product is a Normed Vector Space\<close>

instantiation prod :: (real_normed_vector, real_normed_vector) real_normed_vector
begin

definition norm_prod_def[code del]:
  "norm x = sqrt ((norm (fst x))\<^sup>2 + (norm (snd x))\<^sup>2)"

definition sgn_prod_def:
  "sgn (x::'a \<times> 'b) = scaleR (inverse (norm x)) x"

proposition norm_Pair: "norm (a, b) = sqrt ((norm a)\<^sup>2 + (norm b)\<^sup>2)"
  unfolding norm_prod_def by simp

instance
proof
  fix r :: real and x y :: "'a \<times> 'b"
  show "norm x = 0 \<longleftrightarrow> x = 0"
    unfolding norm_prod_def
    by (simp add: prod_eq_iff)
  show "norm (x + y) \<le> norm x + norm y"
    unfolding norm_prod_def
    apply (rule order_trans [OF _ real_sqrt_sum_squares_triangle_ineq])
    apply (simp add: add_mono power_mono norm_triangle_ineq)
    done
  show "norm (scaleR r x) = \<bar>r\<bar> * norm x"
    unfolding norm_prod_def
    apply (simp add: power_mult_distrib)
    apply (simp add: distrib_left [symmetric])
    apply (simp add: real_sqrt_mult)
    done
  show "sgn x = scaleR (inverse (norm x)) x"
    by (rule sgn_prod_def)
  show "dist x y = norm (x - y)"
    unfolding dist_prod_def norm_prod_def
    by (simp add: dist_norm)
qed

end

declare [[code abort: "norm::('a::real_normed_vector*'b::real_normed_vector) \<Rightarrow> real"]]

instance\<^marker>\<open>tag important\<close> prod :: (banach, banach) banach ..

subsubsection\<^marker>\<open>tag unimportant\<close> \<open>Pair operations are linear\<close>

lemma bounded_linear_fst: "bounded_linear fst"
  using fst_add fst_scaleR
  by (rule bounded_linear_intro [where K=1], simp add: norm_prod_def)

lemma bounded_linear_snd: "bounded_linear snd"
  using snd_add snd_scaleR
  by (rule bounded_linear_intro [where K=1], simp add: norm_prod_def)

lemmas bounded_linear_fst_comp = bounded_linear_fst[THEN bounded_linear_compose]

lemmas bounded_linear_snd_comp = bounded_linear_snd[THEN bounded_linear_compose]

lemma bounded_linear_Pair:
  assumes f: "bounded_linear f"
  assumes g: "bounded_linear g"
  shows "bounded_linear (\<lambda>x. (f x, g x))"
proof
  interpret f: bounded_linear f by fact
  interpret g: bounded_linear g by fact
  fix x y and r :: real
  show "(f (x + y), g (x + y)) = (f x, g x) + (f y, g y)"
    by (simp add: f.add g.add)
  show "(f (r *\<^sub>R x), g (r *\<^sub>R x)) = r *\<^sub>R (f x, g x)"
    by (simp add: f.scale g.scale)
  obtain Kf where "0 < Kf" and norm_f: "\<And>x. norm (f x) \<le> norm x * Kf"
    using f.pos_bounded by fast
  obtain Kg where "0 < Kg" and norm_g: "\<And>x. norm (g x) \<le> norm x * Kg"
    using g.pos_bounded by fast
  have "\<forall>x. norm (f x, g x) \<le> norm x * (Kf + Kg)"
    apply (rule allI)
    apply (simp add: norm_Pair)
    apply (rule order_trans [OF sqrt_add_le_add_sqrt], simp, simp)
    apply (simp add: distrib_left)
    apply (rule add_mono [OF norm_f norm_g])
    done
  then show "\<exists>K. \<forall>x. norm (f x, g x) \<le> norm x * K" ..
qed

subsubsection\<^marker>\<open>tag unimportant\<close> \<open>Frechet derivatives involving pairs\<close>

text\<^marker>\<open>tag important\<close> \<open>%whitespace\<close>
proposition has_derivative_Pair [derivative_intros]:
  assumes f: "(f has_derivative f') (at x within s)"
    and g: "(g has_derivative g') (at x within s)"
  shows "((\<lambda>x. (f x, g x)) has_derivative (\<lambda>h. (f' h, g' h))) (at x within s)"
proof (rule has_derivativeI_sandwich[of 1])
  show "bounded_linear (\<lambda>h. (f' h, g' h))"
    using f g by (intro bounded_linear_Pair has_derivative_bounded_linear)
  let ?Rf = "\<lambda>y. f y - f x - f' (y - x)"
  let ?Rg = "\<lambda>y. g y - g x - g' (y - x)"
  let ?R = "\<lambda>y. ((f y, g y) - (f x, g x) - (f' (y - x), g' (y - x)))"

  show "((\<lambda>y. norm (?Rf y) / norm (y - x) + norm (?Rg y) / norm (y - x)) \<longlongrightarrow> 0) (at x within s)"
    using f g by (intro tendsto_add_zero) (auto simp: has_derivative_iff_norm)

  fix y :: 'a assume "y \<noteq> x"
  show "norm (?R y) / norm (y - x) \<le> norm (?Rf y) / norm (y - x) + norm (?Rg y) / norm (y - x)"
    unfolding add_divide_distrib [symmetric]
    by (simp add: norm_Pair divide_right_mono order_trans [OF sqrt_add_le_add_sqrt])
qed simp

lemma differentiable_Pair [simp, derivative_intros]:
  "f differentiable at x within s \<Longrightarrow> g differentiable at x within s \<Longrightarrow>
    (\<lambda>x. (f x, g x)) differentiable at x within s"
  unfolding differentiable_def by (blast intro: has_derivative_Pair)

lemmas has_derivative_fst [derivative_intros] = bounded_linear.has_derivative [OF bounded_linear_fst]
lemmas has_derivative_snd [derivative_intros] = bounded_linear.has_derivative [OF bounded_linear_snd]

lemma has_derivative_split [derivative_intros]:
  "((\<lambda>p. f (fst p) (snd p)) has_derivative f') F \<Longrightarrow> ((\<lambda>(a, b). f a b) has_derivative f') F"
  unfolding split_beta' .

subsubsection\<^marker>\<open>tag unimportant\<close> \<open>Vector derivatives involving pairs\<close>

lemma has_vector_derivative_Pair[derivative_intros]:
  assumes "(f has_vector_derivative f') (at x within s)"
    "(g has_vector_derivative g') (at x within s)"
  shows "((\<lambda>x. (f x, g x)) has_vector_derivative (f', g')) (at x within s)"
  using assms
  by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros)

lemma
  fixes x :: "'a::real_normed_vector"
  shows norm_Pair1 [simp]: "norm (0,x) = norm x"
    and norm_Pair2 [simp]: "norm (x,0) = norm x"
by (auto simp: norm_Pair)

lemma norm_commute: "norm (x,y) = norm (y,x)"
  by (simp add: norm_Pair)

lemma norm_fst_le: "norm x \<le> norm (x,y)"
  by (metis dist_fst_le fst_conv fst_zero norm_conv_dist)

lemma norm_snd_le: "norm y \<le> norm (x,y)"
  by (metis dist_snd_le snd_conv snd_zero norm_conv_dist)

lemma norm_Pair_le:
  shows "norm (x, y) \<le> norm x + norm y"
  unfolding norm_Pair
  by (metis norm_ge_zero sqrt_sum_squares_le_sum)

lemma (in vector_space_prod) span_Times_sing1: "p.span ({0} \<times> B) = {0} \<times> vs2.span B"
  apply (rule p.span_unique)
  subgoal by (auto intro!: vs1.span_base vs2.span_base)
  subgoal using vs1.subspace_single_0 vs2.subspace_span by (rule subspace_Times)
  subgoal for T
  proof safe
    fix b
    assume subset_T: "{0} \<times> B \<subseteq> T" and subspace: "p.subspace T" and b_span: "b \<in> vs2.span B"
    then obtain t r where b: "b = (\<Sum>a\<in>t. r a *b a)" and t: "finite t" "t \<subseteq> B"
      by (auto simp: vs2.span_explicit)
    have "(0, b) = (\<Sum>b\<in>t. scale (r b) (0, b))"
      unfolding b scale_prod sum_prod
      by simp
    also have "\<dots> \<in> T"
      using \<open>t \<subseteq> B\<close> subset_T
      by (auto intro!: p.subspace_sum p.subspace_scale subspace)
    finally show "(0, b) \<in> T" .
  qed
  done

lemma (in vector_space_prod) span_Times_sing2: "p.span (A \<times> {0}) = vs1.span A \<times> {0}"
  apply (rule p.span_unique)
  subgoal by (auto intro!: vs1.span_base vs2.span_base)
  subgoal using vs1.subspace_span vs2.subspace_single_0 by (rule subspace_Times)
  subgoal for T
  proof safe
    fix a
    assume subset_T: "A \<times> {0} \<subseteq> T" and subspace: "p.subspace T" and a_span: "a \<in> vs1.span A"
    then obtain t r where a: "a = (\<Sum>a\<in>t. r a *a a)" and t: "finite t" "t \<subseteq> A"
      by (auto simp: vs1.span_explicit)
    have "(a, 0) = (\<Sum>a\<in>t. scale (r a) (a, 0))"
      unfolding a scale_prod sum_prod
      by simp
    also have "\<dots> \<in> T"
      using \<open>t \<subseteq> A\<close> subset_T
      by (auto intro!: p.subspace_sum p.subspace_scale subspace)
    finally show "(a, 0) \<in> T" .
  qed
  done

subsection \<open>Product is Finite Dimensional\<close>

lemma (in finite_dimensional_vector_space) zero_not_in_Basis[simp]: "0 \<notin> Basis"
  using dependent_zero local.independent_Basis by blast

locale finite_dimensional_vector_space_prod = vector_space_prod + finite_dimensional_vector_space_pair begin

definition "Basis_pair = B1 \<times> {0} \<union> {0} \<times> B2"

sublocale p: finite_dimensional_vector_space scale Basis_pair
proof unfold_locales
  show "finite Basis_pair"
    by (auto intro!: finite_cartesian_product vs1.finite_Basis vs2.finite_Basis simp: Basis_pair_def)
  show "p.independent Basis_pair"
    unfolding p.dependent_def Basis_pair_def
  proof safe
    fix a
    assume a: "a \<in> B1"
    assume "(a, 0) \<in> p.span (B1 \<times> {0} \<union> {0} \<times> B2 - {(a, 0)})"
    also have "B1 \<times> {0} \<union> {0} \<times> B2 - {(a, 0)} = (B1 - {a}) \<times> {0} \<union> {0} \<times> B2"
      by auto
    finally show False
      using a vs1.dependent_def vs1.independent_Basis
      by (auto simp: p.span_Un span_Times_sing1 span_Times_sing2)
  next
    fix b
    assume b: "b \<in> B2"
    assume "(0, b) \<in> p.span (B1 \<times> {0} \<union> {0} \<times> B2 - {(0, b)})"
    also have "(B1 \<times> {0} \<union> {0} \<times> B2 - {(0, b)}) = B1 \<times> {0} \<union> {0} \<times> (B2 - {b})"
      by auto
    finally show False
      using b vs2.dependent_def vs2.independent_Basis
      by (auto simp: p.span_Un span_Times_sing1 span_Times_sing2)
  qed
  show "p.span Basis_pair = UNIV"
    by (auto simp: p.span_Un span_Times_sing2 span_Times_sing1 vs1.span_Basis vs2.span_Basis
        Basis_pair_def)
qed

proposition dim_Times:
  assumes "vs1.subspace S" "vs2.subspace T"
  shows "p.dim(S \<times> T) = vs1.dim S + vs2.dim T"
proof -
  interpret p1: Vector_Spaces.linear s1 scale "(\<lambda>x. (x, 0))"
    by unfold_locales (auto simp: scale_def)
  interpret pair1: finite_dimensional_vector_space_pair "(*a)" B1 scale Basis_pair
    by unfold_locales
  interpret p2: Vector_Spaces.linear s2 scale "(\<lambda>x. (0, x))"
    by unfold_locales (auto simp: scale_def)
  interpret pair2: finite_dimensional_vector_space_pair "(*b)" B2 scale Basis_pair
    by unfold_locales
  have ss: "p.subspace ((\<lambda>x. (x, 0)) ` S)" "p.subspace (Pair 0 ` T)"
    by (rule p1.subspace_image p2.subspace_image assms)+
  have "p.dim(S \<times> T) = p.dim({u + v |u v. u \<in> (\<lambda>x. (x, 0)) ` S \<and> v \<in> Pair 0 ` T})"
    by (simp add: Times_eq_image_sum)
  moreover have "p.dim ((\<lambda>x. (x, 0::'c)) ` S) = vs1.dim S" "p.dim (Pair (0::'b) ` T) = vs2.dim T"
     by (simp_all add: inj_on_def p1.linear_axioms pair1.dim_image_eq p2.linear_axioms pair2.dim_image_eq)
  moreover have "p.dim ((\<lambda>x. (x, 0)) ` S \<inter> Pair 0 ` T) = 0"
    by (subst p.dim_eq_0) auto
  ultimately show ?thesis
    using p.dim_sums_Int [OF ss] by linarith
qed

lemma dimension_pair: "p.dimension = vs1.dimension + vs2.dimension"
  using dim_Times[OF vs1.subspace_UNIV vs2.subspace_UNIV]
  by (auto simp: p.dimension_def vs1.dimension_def vs2.dimension_def)

end

end


section "Amortized Complexity Framework"

theory Amortized_Framework
imports Complex_Main
begin

text\<open>This theory provides a framework for amortized analysis.\<close>

datatype 'a rose_tree = T 'a "'a rose_tree list"

declare length_Suc_conv [simp]

locale Amortized =
fixes arity :: "'op \<Rightarrow> nat"
fixes exec :: "'op \<Rightarrow> 's list \<Rightarrow> 's"
fixes inv :: "'s \<Rightarrow> bool"
fixes cost :: "'op \<Rightarrow> 's list \<Rightarrow> nat"
fixes \<Phi> :: "'s \<Rightarrow> real"
fixes U :: "'op \<Rightarrow> 's list \<Rightarrow> real"
assumes inv_exec: "\<lbrakk>\<forall>s \<in> set ss. inv s; length ss = arity f \<rbrakk> \<Longrightarrow> inv(exec f ss)"
assumes ppos: "inv s \<Longrightarrow> \<Phi> s \<ge> 0"
assumes U: "\<lbrakk> \<forall>s \<in> set ss. inv s; length ss = arity f \<rbrakk>
 \<Longrightarrow> cost f ss + \<Phi>(exec f ss) - sum_list (map \<Phi> ss) \<le> U f ss"
begin

fun wf :: "'op rose_tree \<Rightarrow> bool" where
"wf (T f ts) = (length ts = arity f \<and> (\<forall>t \<in> set ts. wf t))"

fun state :: "'op rose_tree \<Rightarrow> 's" where
"state (T f ts) = exec f (map state ts)"

lemma inv_state: "wf ot \<Longrightarrow> inv(state ot)"
by(induction ot)(simp_all add: inv_exec)

definition acost :: "'op \<Rightarrow> 's list \<Rightarrow> real" where
"acost f ss = cost f ss + \<Phi> (exec f ss) - sum_list (map \<Phi> ss)"

fun acost_sum :: "'op rose_tree \<Rightarrow> real" where
"acost_sum (T f ts) = acost f (map state ts) + sum_list (map acost_sum ts)"

fun cost_sum :: "'op rose_tree \<Rightarrow> real" where
"cost_sum (T f ts) = cost f (map state ts) + sum_list (map cost_sum ts)"

fun U_sum :: "'op rose_tree \<Rightarrow> real" where
"U_sum (T f ts) = U f (map state ts) + sum_list (map U_sum ts)"

lemma t_sum_a_sum: "wf ot \<Longrightarrow> cost_sum ot = acost_sum ot - \<Phi>(state ot)"
  by (induction ot) (auto simp: acost_def Let_def sum_list_subtractf cong: map_cong)

corollary t_sum_le_a_sum: "wf ot \<Longrightarrow> cost_sum ot \<le> acost_sum ot"
by (metis add.commute t_sum_a_sum diff_add_cancel le_add_same_cancel2 ppos[OF inv_state])

lemma a_le_U: "\<lbrakk> \<forall>s \<in> set ss. inv s; length ss = arity f \<rbrakk> \<Longrightarrow> acost f ss \<le> U f ss"
by(simp add: acost_def U)

lemma u_sum_le_U_sum: "wf ot \<Longrightarrow> acost_sum ot \<le> U_sum ot"
proof(induction ot)
  case (T f ts)
  with a_le_U[of "map state ts" f] sum_list_mono show ?case
    by (force simp: inv_state)
qed

corollary t_sum_le_U_sum: "wf ot \<Longrightarrow> cost_sum ot \<le> U_sum ot"
by (blast intro: t_sum_le_a_sum u_sum_le_U_sum order.trans)

end

hide_const T

text
\<open>\<open>Amortized2\<close> supports the transfer of amortized analysis of one datatype
(\<open>Amortized arity exec inv cost \<Phi> U\<close> on type \<open>'s\<close>) to an implementation
(primed identifiers on type \<open>'t\<close>).
Function \<open>hom\<close> is assumed to be a homomorphism from \<open>'t\<close> to \<open>'s\<close>,
not just w.r.t. \<open>exec\<close> but also \<open>cost\<close> and \<open>U\<close>. The assumptions about
\<open>inv'\<close> are weaker than the obvious \<open>inv' = inv \<circ> hom\<close>: the latter does
not allow \<open>inv\<close> to be weaker than \<open>inv'\<close> (which we need in one application).\<close>

locale Amortized2 = Amortized arity exec inv cost \<Phi> U
  for arity :: "'op \<Rightarrow> nat" and exec and inv :: "'s \<Rightarrow> bool" and cost \<Phi> U +
fixes exec' :: "'op \<Rightarrow> 't list \<Rightarrow> 't"
fixes inv' :: "'t \<Rightarrow> bool"
fixes cost' :: "'op \<Rightarrow> 't list \<Rightarrow> nat"
fixes U' :: "'op \<Rightarrow> 't list \<Rightarrow> real"
fixes hom :: "'t \<Rightarrow> 's"
assumes exec': "\<lbrakk>\<forall>s \<in> set ts. inv' s; length ts = arity f \<rbrakk>
  \<Longrightarrow> hom(exec' f ts) = exec f (map hom ts)"
assumes inv_exec': "\<lbrakk>\<forall>s \<in> set ss. inv' s; length ss = arity f \<rbrakk>
  \<Longrightarrow> inv'(exec' f ss)"
assumes inv_hom: "inv' t \<Longrightarrow> inv (hom t)"
assumes cost': "\<lbrakk>\<forall>s \<in> set ts. inv' s; length ts = arity f \<rbrakk>
  \<Longrightarrow> cost' f ts = cost f (map hom ts)"
assumes U': "\<lbrakk>\<forall>s \<in> set ts. inv' s; length ts = arity f \<rbrakk>
  \<Longrightarrow> U' f ts = U f (map hom ts)"
begin

sublocale A': Amortized arity exec' inv' cost' "\<Phi> o hom" U'
proof (standard, goal_cases)
  case 1 thus ?case by(simp add: exec' inv_exec' inv_exec)
next
  case 2 thus ?case by(simp add: inv_hom ppos)
next
  case 3 thus ?case
    by(simp add: U exec' U' map_map[symmetric] cost' inv_exec inv_hom del: map_map)
qed

end

end


theory CauchySchwarz imports "HOL-Analysis.Analysis"
begin

definition concave_on :: "'a::real_vector set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> bool"
  where "concave_on S f \<equiv> convex_on S (\<lambda>x. - f x)"

lemma concave_on_iff:
  "concave_on S f \<longleftrightarrow>
    (\<forall>x\<in>S. \<forall>y\<in>S. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> f (u *\<^sub>R x + v *\<^sub>R y) \<ge> u * f x + v * f y)"
  by (auto simp: concave_on_def convex_on_def algebra_simps)

lemma ln_concave: "concave_on {0<..} ln"
  unfolding concave_on_def
  by (rule f''_ge0_imp_convex derivative_eq_intros | simp)+

lemma powr_convex:
  assumes "p \<ge> 1" shows "convex_on {0<..} (\<lambda>x. x powr p)"
  using assms
  by (intro f''_ge0_imp_convex derivative_eq_intros | simp)+

lemma Youngs_inequality_0:
  fixes a::real
  assumes "0 \<le> \<alpha>" "0 \<le> \<beta>" "\<alpha>+\<beta> = 1" "a>0" "b>0"
  shows "a powr \<alpha> * b powr \<beta> \<le> \<alpha>*a + \<beta>*b"
proof -
  have "\<alpha> * ln a + \<beta> * ln b \<le> ln (\<alpha> * a + \<beta> * b)"
    using assms ln_concave by (simp add: concave_on_iff)
  moreover have "0 < \<alpha> * a + \<beta> * b"
    using assms by (smt (verit) mult_pos_pos split_mult_pos_le)
  ultimately show ?thesis
    using assms by (simp add: powr_def mult_exp_exp flip: ln_ge_iff)
qed

lemma Youngs_inequality:
  fixes p::real
  assumes "p>1" "q>1" "1/p + 1/q = 1" "a\<ge>0" "b\<ge>0"
  shows "a * b \<le> a powr p / p + b powr q / q"
proof (cases "a=0 \<or> b=0")
  case False
  then show ?thesis
  using Youngs_inequality_0 [of "1/p" "1/q" "a powr p" "b powr q"] assms
  by (simp add: powr_powr)
qed (use assms in auto)

lemma Cauchy_Schwarz_ineq_sum:
  fixes a :: "'a \<Rightarrow> 'b::linordered_field"
  shows "(\<Sum>i\<in>I. a i * b i)\<^sup>2 \<le> (\<Sum>i\<in>I. (a i)\<^sup>2) * (\<Sum>i\<in>I. (b i)\<^sup>2)"
proof (cases "(\<Sum>i\<in>I. (b i)\<^sup>2) > 0")
  case False
  then consider "\<And>i. i\<in>I \<Longrightarrow> b i = 0" | "infinite I"
    by (metis (mono_tags, lifting) sum_pos2 zero_le_power2 zero_less_power2)
  thus ?thesis
    by fastforce
next
  case True
  define r where "r \<equiv> (\<Sum>i\<in>I. a i * b i) / (\<Sum>i\<in>I. (b i)\<^sup>2)"
  with True have *: "(\<Sum>i\<in>I. a i * b i) = r * (\<Sum>i\<in>I. (b i)\<^sup>2)"
    by simp
  have "0 \<le> (\<Sum>i\<in>I. (a i - r * b i)\<^sup>2)"
    by (meson sum_nonneg zero_le_power2)
  also have "... = (\<Sum>i\<in>I. (a i)\<^sup>2) - 2 * r * (\<Sum>i\<in>I. a i * b i) + r\<^sup>2 * (\<Sum>i\<in>I. (b i)\<^sup>2)"
    by (simp add: algebra_simps power2_eq_square sum_distrib_left flip: sum.distrib)
  also have "\<dots> = (\<Sum>i\<in>I. (a i)\<^sup>2) - (\<Sum>i\<in>I. a i * b i) * r"
    by (simp add: * power2_eq_square)
  also have "\<dots> = (\<Sum>i\<in>I. (a i)\<^sup>2) - ((\<Sum>i\<in>I. a i * b i))\<^sup>2 / (\<Sum>i\<in>I. (b i)\<^sup>2)"
    by (simp add: r_def power2_eq_square)
  finally have "0 \<le> (\<Sum>i\<in>I. (a i)\<^sup>2) - ((\<Sum>i\<in>I. a i * b i))\<^sup>2 / (\<Sum>i\<in>I. (b i)\<^sup>2)" .
  hence "((\<Sum>i\<in>I. a i * b i))\<^sup>2 / (\<Sum>i\<in>I. (b i)\<^sup>2) \<le> (\<Sum>i\<in>I. (a i)\<^sup>2)"
    by (simp add: le_diff_eq)
  thus "((\<Sum>i\<in>I. a i * b i))\<^sup>2 \<le> (\<Sum>i\<in>I. (a i)\<^sup>2) * (\<Sum>i\<in>I. (b i)\<^sup>2)"
    by (simp add: pos_divide_le_eq True)
qed

lemma "\<exists>f'. ((\<lambda>x. x^3 + x\<^sup>2) has_real_derivative f' x) (at x) \<and> P (\<lambda>x. f' x)"
  apply (rule exI conjI derivative_eq_intros | simp)+
  oops

lemma "x > 0 \<Longrightarrow> \<exists>f'. ((\<lambda>x. (x\<^sup>2 - 1) * ln x) has_real_derivative f' x) (at x) \<and> P (\<lambda>x. f' x)"
  apply (rule exI conjI derivative_eq_intros | simp)+
  oops

lemma "\<exists>f'. ((\<lambda>x. (sin x)\<^sup>2 + (cos x)\<^sup>2) has_real_derivative f' x) (at x) \<and> P (\<lambda>x. f' x)"
  apply (rule exI conjI derivative_eq_intros | simp)+
  oops

end


(*
Author: Tobias Nipkow
Function follow AFP entry Splay_Tree, proofs are new.
*)

section "Splay Tree Implementation of Sets"

theory Splay_Set
imports
  "~~/src/HOL/Library/Tree"
  Set_by_Ordered
  Cmp
begin

function splay :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"splay a Leaf = Leaf" |
"splay a (Node t1 a t2) = Node t1 a t2" |
"a<b \<Longrightarrow> splay a (Node (Node t1 a t2) b t3) = Node t1 a (Node t2 b t3)" |
"x<a \<Longrightarrow> splay x (Node Leaf a t) = Node Leaf a t" |
"x<a \<Longrightarrow> x<b \<Longrightarrow> splay x (Node (Node Leaf a t1) b t2) = Node Leaf a (Node t1 b t2)" |
"x<a \<Longrightarrow> x<b \<Longrightarrow> t1 \<noteq> Leaf \<Longrightarrow>
 splay x (Node (Node t1 a t2) b t3) =
 (case splay x t1 of Node t11 y t12 \<Rightarrow> Node t11 y (Node t12 a (Node t2 b t3)))" |
"a<x \<Longrightarrow> x<b \<Longrightarrow> splay x (Node (Node t1 a Leaf) b t2) = Node t1 a (Node Leaf b t2)" |
"a<x \<Longrightarrow> x<b \<Longrightarrow> t2 \<noteq> Leaf \<Longrightarrow>
 splay x (Node (Node t1 a t2) b t3) =
 (case splay x t2 of Node t21 y t22 \<Rightarrow> Node (Node t1 a t21) y (Node t22 b t3))" |
"a<b \<Longrightarrow> splay b (Node t1 a (Node t2 b t3)) = Node (Node t1 a t2) b t3" |
"a<x \<Longrightarrow> splay x (Node t a Leaf) = Node t a Leaf" |
"a<x \<Longrightarrow> x<b \<Longrightarrow>  t2 \<noteq> Leaf \<Longrightarrow>
 splay x (Node t1 a (Node t2 b t3)) =
 (case splay x t2 of Node t21 y t22 \<Rightarrow> Node (Node t1 a t21) y (Node t22 b t3))" |
"a<x \<Longrightarrow> x<b \<Longrightarrow> splay x (Node t1 a (Node Leaf b t2)) = Node (Node t1 a Leaf) b t2" |
"a<x \<Longrightarrow> b<x \<Longrightarrow> splay x (Node t1 a (Node t2 b Leaf)) = Node (Node t1 a t2) b Leaf" |
"a<x \<Longrightarrow> b<x \<Longrightarrow>  t3 \<noteq> Leaf \<Longrightarrow>
 splay x (Node t1 a (Node t2 b t3)) =
 (case splay x t3 of Node t31 y t32 \<Rightarrow> Node (Node (Node t1 a t2) b t31) y t32)"
apply(atomize_elim)
apply(auto)
(* 1 subgoal *)
apply (subst (asm) neq_Leaf_iff)
apply(auto)
apply (metis tree.exhaust less_linear)+
done

termination splay
by lexicographic_order

(* no idea why this speeds things up below *)
lemma case_tree_cong:
  "\<lbrakk> x = x'; y = y'; z = z' \<rbrakk> \<Longrightarrow> case_tree x y z = case_tree x' y' z'"
by auto

lemma splay_code: "splay (x::_::linorder) t = (case t of Leaf \<Rightarrow> Leaf |
  Node al a ar \<Rightarrow> (case cmp x a of
    EQ \<Rightarrow> t |
    LT \<Rightarrow> (case al of
      Leaf \<Rightarrow> t |
      Node bl b br \<Rightarrow> (case cmp x b of
        EQ \<Rightarrow> Node bl b (Node br a ar) |
        LT \<Rightarrow> if bl = Leaf then Node bl b (Node br a ar)
              else case splay x bl of
                Node bll y blr \<Rightarrow> Node bll y (Node blr b (Node br a ar)) |
        GT \<Rightarrow> if br = Leaf then Node bl b (Node br a ar)
              else case splay x br of
                Node brl y brr \<Rightarrow> Node (Node bl b brl) y (Node brr a ar))) |
    GT \<Rightarrow> (case ar of
      Leaf \<Rightarrow> t |
      Node bl b br \<Rightarrow> (case cmp x b of
        EQ \<Rightarrow> Node (Node al a bl) b br |
        LT \<Rightarrow> if bl = Leaf then Node (Node al a bl) b br
              else case splay x bl of
                Node bll y blr \<Rightarrow> Node (Node al a bll) y (Node blr b br) |
        GT \<Rightarrow> if br=Leaf then Node (Node al a bl) b br
              else case splay x br of
                Node bll y blr \<Rightarrow> Node (Node (Node al a bl) b bll) y blr))))"
by(auto cong: case_tree_cong split: tree.split)

definition is_root :: "'a \<Rightarrow> 'a tree \<Rightarrow> bool" where
"is_root x t = (case t of Leaf \<Rightarrow> False | Node l a r \<Rightarrow> x = a)"

definition "isin t x = is_root x (splay x t)"

hide_const (open) insert

fun insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x t =
  (if t = Leaf then Node Leaf x Leaf
   else case splay x t of
     Node l a r \<Rightarrow>
      case cmp x a of
        EQ \<Rightarrow> Node l a r |
        LT \<Rightarrow> Node l x (Node Leaf a r) |
        GT \<Rightarrow> Node (Node l a Leaf) x r)"

fun splay_max :: "'a tree \<Rightarrow> 'a tree" where
"splay_max Leaf = Leaf" |
"splay_max (Node l b Leaf) = Node l b Leaf" |
"splay_max (Node l b (Node rl c rr)) =
  (if rr = Leaf then Node (Node l b rl) c Leaf
   else case splay_max rr of
     Node rrl m rrr \<Rightarrow> Node (Node (Node l b rl) c rrl) m rrr)"

definition delete :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"delete x t =
  (if t = Leaf then Leaf
   else case splay x t of Node l a r \<Rightarrow>
     if x = a
     then if l = Leaf then r else case splay_max l of Node l' m r' \<Rightarrow> Node l' m r
     else Node l a r)"

subsection "Functional Correctness Proofs"

lemma splay_Leaf_iff: "(splay a t = Leaf) = (t = Leaf)"
by(induction a t rule: splay.induct) (auto split: tree.splits)

lemma splay_max_Leaf_iff: "(splay_max t = Leaf) = (t = Leaf)"
by(induction t rule: splay_max.induct)(auto split: tree.splits)

subsubsection "Proofs for isin"

lemma
  "splay x t = Node l a r \<Longrightarrow> sorted(inorder t) \<Longrightarrow>
  x \<in> elems (inorder t) \<longleftrightarrow> x=a"
by(induction x t arbitrary: l a r rule: splay.induct)
  (auto simp: elems_simps1 splay_Leaf_iff ball_Un split: tree.splits)

lemma splay_elemsD:
  "splay x t = Node l a r \<Longrightarrow> sorted(inorder t) \<Longrightarrow>
  x \<in> elems (inorder t) \<longleftrightarrow> x=a"
by(induction x t arbitrary: l a r rule: splay.induct)
  (auto simp: elems_simps2 splay_Leaf_iff split: tree.splits)

lemma isin_set: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> elems (inorder t))"
by (auto simp: isin_def is_root_def splay_elemsD splay_Leaf_iff split: tree.splits)

subsubsection "Proofs for insert"

lemma inorder_splay: "inorder(splay x t) = inorder t"
by(induction x t rule: splay.induct)
  (auto simp: neq_Leaf_iff split: tree.split)

lemma sorted_splay:
  "sorted(inorder t) \<Longrightarrow> splay x t = Node l a r \<Longrightarrow>
  sorted(inorder l @ x # inorder r)"
unfolding inorder_splay[of x t, symmetric]
by(induction x t arbitrary: l a r rule: splay.induct)
  (auto simp: sorted_lems sorted_Cons_le sorted_snoc_le splay_Leaf_iff split: tree.splits)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
using inorder_splay[of x t, symmetric] sorted_splay[of t x]
by(auto simp: ins_list_simps ins_list_Cons ins_list_snoc neq_Leaf_iff split: tree.split)

subsubsection "Proofs for delete"

lemma inorder_splay_maxD:
  "splay_max t = Node l a r \<Longrightarrow> sorted(inorder t) \<Longrightarrow>
  inorder l @ [a] = inorder t \<and> r = Leaf"
by(induction t arbitrary: l a r rule: splay_max.induct)
  (auto simp: sorted_lems splay_max_Leaf_iff split: tree.splits if_splits)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
using inorder_splay[of x t, symmetric] sorted_splay[of t x]
by (auto simp: del_list_simps del_list_sorted_app delete_def
  del_list_notin_Cons inorder_splay_maxD splay_Leaf_iff splay_max_Leaf_iff
  split: tree.splits)

subsubsection "Overall Correctness"

interpretation Set_by_Ordered
where empty = Leaf and isin = isin and insert = insert
and delete = delete and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert del: insert.simps)
next
  case 4 thus ?case by(simp add: inorder_delete)
qed auto

end


(*
    Author:     Wenda Li <wl302@cam.ac.uk>
*)

theory PolyMisc imports
  Complex_Main
  "~~/src/HOL/Library/Poly_Deriv"
begin

section{*lead coefficient*}

definition lead_coeff:: "'a::zero poly \<Rightarrow> 'a" where
  "lead_coeff p= coeff p (degree p)"

section{*Misc*}

lemma smult_cancel:
  fixes p::"'a::idom poly"
  assumes "c\<noteq>0" and smult: "smult c p = smult c q"
  shows "p=q"
proof -
  have "smult c (p-q)=0" using smult by (metis diff_self smult_diff_right)
  thus ?thesis using `c\<noteq>0` by auto
qed

lemma dvd_monic:
  fixes p q:: "'a :: idom poly"
  assumes monic:"lead_coeff p=1" and "p dvd (smult c q)" and "c\<noteq>0"
  shows "p dvd q" using assms
proof (cases "q=0 \<or> degree p=0")
  case True
  thus ?thesis using assms unfolding lead_coeff_def
    by (metis coeff_1 dvd_0_right le_0_eq le_degree one_dvd poly_eqI)
next
  case False
  hence "q\<noteq>0" and "degree p\<noteq>0" by auto
  obtain k where k:"smult c q = p*k" using assms by (blast elim: dvdE)
  hence "k\<noteq>0" by (metis False assms(3) mult_zero_right smult_eq_0_iff)
  hence deg_eq:"degree q=degree p + degree k"
    using degree_mult_eq monic k unfolding lead_coeff_def
    by (metis assms(3) degree_smult_eq leading_coeff_0_iff zero_neq_one)
  have c_dvd:"\<forall>n\<le>degree k. c dvd coeff k (degree k - n)"
    proof (rule,rule)
      fix n assume "n \<le> degree k "
      thus "c dvd coeff k (degree k - n)"
        proof (induct n rule:nat_less_induct)
          case (1 n)
          def T\<equiv>"(\<lambda>i. coeff p i * coeff k (degree p+degree k - n - i))"
          have "c * coeff q (degree q - n) = (\<Sum>i\<le>degree q - n. coeff p i * coeff k (degree q - n - i))"
            using coeff_mult[of p k "degree q - n"] k coeff_smult[of c q "degree q -n"] by auto
          also have "...=(\<Sum>i\<le>degree p+degree k - n. T i)"
            using deg_eq unfolding T_def by auto
          also have "...=(\<Sum>i\<in>{0..<degree p}. T i) + setsum T {(degree p)}+
                  setsum T {degree p + 1..degree p + degree k - n}"
            proof -
              def C\<equiv>"{{0..<degree p}, {degree p},{degree p+1..degree p+degree k-n}}"
              have "\<forall>A\<in>C. finite A" unfolding C_def by auto
              moreover have "\<forall>A\<in>C. \<forall>B\<in>C. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
                unfolding C_def by auto
              ultimately have "setsum T (\<Union>C) = setsum (setsum T) C"
                using setsum.Union_disjoint by auto
              moreover have "\<Union>C={..degree p + degree k - n}"
                using `n \<le> degree k` unfolding C_def by auto
              moreover have  "setsum (setsum T) C= setsum T {0..<degree p} + setsum T {(degree p)} +
                  setsum T {degree p + 1..degree p + degree k - n}"
                proof -
                  have "{0..<degree p}\<noteq>{degree p}"
                    by (metis atLeast0LessThan insertI1 lessThan_iff less_imp_not_eq)
                  moreover have "{degree p}\<noteq>{degree p + 1..degree p + degree k - n}"
                    by (metis add.commute add_diff_cancel_right' atLeastAtMost_singleton_iff
                      diff_self_eq_0 eq_imp_le not_one_le_zero)
                  moreover have "{0..<degree p}\<noteq>{degree p + 1..degree p + degree k - n}"
                    using `degree k\<ge>n` `degree p\<noteq>0` by fastforce
                  ultimately show ?thesis unfolding C_def by auto
                qed
              ultimately show ?thesis by auto
            qed
          also have "...=(\<Sum>i\<in>{0..<degree p}. T i) +  coeff k (degree k - n)"
            proof -
              have "\<forall>x\<in>{degree p + 1..degree p + degree k - n}. T x=0"
                using coeff_eq_0[of p] unfolding T_def by simp
              hence "setsum T {degree p + 1..degree p + degree k - n}=0" by auto
              moreover have "T (degree p)=coeff k (degree k - n)"
                using monic unfolding T_def lead_coeff_def by auto
              ultimately show ?thesis by auto
            qed
          finally have c_coeff: "c * coeff q (degree q - n) = setsum T {0..<degree p}
              + coeff k (degree k - n)" .
          moreover have "n\<noteq>0\<Longrightarrow>c dvd setsum T {0..<degree p}"
            proof (rule dvd_setsum)
              fix i assume i:"i \<in> {0..<degree p}" and "n\<noteq>0"
              hence "(n+i-degree p)\<le>degree k" using `n \<le> degree k` by auto
              moreover have "n + i - degree p <n" using i `n\<noteq>0` by auto
              ultimately have "c dvd coeff k (degree k - (n+i-degree p))"
                using 1(1) by auto
              hence "c dvd coeff k (degree p + degree k - n - i)"
                by (metis add_diff_cancel_left' deg_eq diff_diff_left dvd_0_right le_degree
                  le_diff_conv add.commute ordered_cancel_comm_monoid_diff_class.diff_diff_right)
              thus "c dvd T i" unfolding T_def by auto
            qed
          moreover have "n=0 \<Longrightarrow>?case"
            proof -
              assume "n=0"
              hence "\<forall>i\<in>{0..<degree p}. coeff k (degree p + degree k - n - i) =0"
                using coeff_eq_0[of k] by simp
              hence "c * coeff q (degree q - n) = coeff k (degree k - n)"
                using c_coeff unfolding T_def by auto
              thus ?thesis by (metis dvdI)
            qed
          ultimately show ?case using dvd_add_cancel1 by (metis dvd_triv_left)
        qed
    qed
  hence "\<forall>n. c dvd coeff k n"
    by (metis diff_diff_cancel dvd_0_right le_add2 le_add_diff_inverse le_degree)
  then obtain f where f:"\<forall>n. c * f n=coeff k n" unfolding dvd_def by metis
  have "almost_everywhere_zero f"
    unfolding almost_everywhere_zero_def
    by (rule_tac x="degree k" in exI , metis f assms(3) coeff_eq_0 mult_eq_0_iff)
  hence "smult c (Abs_poly f)=k"
    using f smult.abs_eq[of c "Abs_poly f"] Abs_poly_inverse[of f] coeff_inverse[of k]
    by simp
  hence "q=p* Abs_poly f" using k `c\<noteq>0` smult_cancel by auto
  thus ?thesis unfolding dvd_def by auto
qed

lemma order_smult:
  assumes "c\<noteq>0"
  shows "order x (smult c p) = order x p "
proof -
  have " \<forall>n. let p=[:- x, 1:] ^ Suc n in lead_coeff p=1"
    unfolding lead_coeff_def by (metis coeff_linear_power degree_linear_power)
  hence "\<forall>n. [:- x, 1:] ^ Suc n dvd smult c p \<longleftrightarrow>  [:- x, 1:] ^ Suc n dvd p"
    using dvd_monic[OF _ _ `c\<noteq>0`] by (metis dvd_smult)
  thus ?thesis unfolding order_def by auto
qed

lemma order_1_eq_0 [simp]:"order x 1=0" by (metis order_root poly_1 zero_neq_one)

lemma order_power_n_n: "order a ([:-a,1:]^n)=n"
proof (induct n) (*might be proved more concisely using nat_less_induct*)
  case 0
  thus ?case by (metis order_root poly_1 power_0 zero_neq_one)
next
  case (Suc n)
  have "order a ([:- a, 1:] ^ Suc n)=order a ([:- a, 1:] ^ n) + order a [:-a,1:]"
    by (metis (no_types, hide_lams) One_nat_def add_Suc_right monoid_add_class.add.right_neutral
      one_neq_zero order_mult pCons_eq_0_iff power_add power_eq_0_iff power_one_right)
  moreover have "order a [:-a,1:]=1" unfolding order_def
    proof (rule Least_equality,rule ccontr)
      assume  "\<not> \<not> [:- a, 1:] ^ Suc 1 dvd [:- a, 1:]"
      hence "[:- a, 1:] ^ Suc 1 dvd [:- a, 1:]" by simp
      hence "degree ([:- a, 1:] ^ Suc 1) \<le> degree ([:- a, 1:] )"
        by (rule dvd_imp_degree_le,auto)
      thus False by auto
    next
      fix y assume asm:"\<not> [:- a, 1:] ^ Suc y dvd [:- a, 1:]"
      show "1 \<le> y"
        proof (rule ccontr)
          assume "\<not> 1 \<le> y"
          hence "y=0" by auto
          hence "[:- a, 1:] ^ Suc y dvd [:- a, 1:]" by auto
          thus False using asm by auto
        qed
    qed
  ultimately show ?case using Suc by auto
qed

lemma poly_power_n_eq:
  fixes x::"'a :: idom"
  assumes "n\<noteq>0"
  shows "poly ([:-a,1:]^n) x=0 \<longleftrightarrow> (x=a)" using assms
by (induct n,auto)

lemma poly_power_n_odd:
  fixes x a:: real
  assumes "odd n"
  shows "poly ([:-a,1:]^n) x>0 \<longleftrightarrow> (x>a)" using assms
proof -
  have "poly ([:-a,1:]^n) x\<ge>0 = (poly [:- a, 1:] x \<ge>0)"
    unfolding poly_power using zero_le_odd_power[OF `odd n`] by auto
  also have "(poly [:- a, 1:] x \<ge>0) = (x\<ge>a)" by fastforce
  finally have "poly ([:-a,1:]^n) x\<ge>0 = (x\<ge>a)" .
  moreover have "poly ([:-a,1:]^n) x=0 = (x=a)" by(rule poly_power_n_eq, metis assms even_zero)
  ultimately show ?thesis by linarith
qed

lemma poly_IVT:
  fixes p::"real poly"
  assumes "a<b" and "poly p a * poly p b < 0"
  shows "\<exists>x>a. x < b \<and> poly p x = 0"
by (metis assms(1) assms(2) less_not_sym mult_less_0_iff poly_IVT_neg poly_IVT_pos)

lemma div_gcd_coprime_poly:
  fixes p q::"'a::field poly"
  assumes nz: "p \<noteq> 0 \<or> q \<noteq> 0"
  shows "coprime (p div gcd p q) (q div gcd p q)"
proof -
  def g \<equiv> "gcd p q"
  def p' \<equiv> "p div g" and  q' \<equiv> "q div g"
  def g' \<equiv> "gcd p' q'"
  have "g dvd p" "g dvd q" "g' dvd p'" "g' dvd q'"  unfolding g_def g'_def by simp_all
  then obtain kp kq kp' kq' where
      kab: "p = g * kp" "q = g * kq" "p' = g' * kp'" "q' = g' * kq'"
    unfolding dvd_def g_def g'_def by blast
  hence "g * p' = (g * g') * kp'" "g * q' = (g * g') * kq'" by simp_all
  then have dvdgg':"g * g' dvd p" "g* g' dvd q"
    using dvd_def dvd_mult_div_cancel [OF `g dvd p`,folded p'_def]
      dvd_mult_div_cancel [OF `g dvd q`,folded q'_def]
    by auto
  hence "g * g' dvd g" using poly_gcd_greatest g_def by auto
  hence "degree g + degree g' \<le> degree g"
    using degree_mult_eq nz dvd_imp_degree_le
    by (metis degree_0 g_def monoid_add_class.add.right_neutral order_refl poly_gcd_zero_iff)
  hence "degree g'=0" by auto
  moreover have "coeff g' (degree g') = 1"
    using poly_gcd_monic[of p' q',folded g'_def] nz unfolding p'_def q'_def
    by (metis `g dvd p` `g dvd q` dvd_div_mult_self mult_eq_0_iff)
  ultimately have "g'=1" by (metis coeff_1 coeff_eq_0 neq0_conv poly_eq_iff)
  thus ?thesis unfolding g'_def p'_def q'_def g_def .
qed

lemma gcd_coprime_poly:
  fixes p q::"'a::field poly"
  assumes nz: "p \<noteq> 0 \<or> q \<noteq> 0" and p': "p = p' * gcd p q" and
    q': "q = q' * gcd p q"
  shows "coprime p' q'"
proof -
  have "p' = p div gcd p q"
    using p' nz by (metis div_mult_self2_is_id poly_gcd_zero_iff)
  moreover have "q'= q div gcd p q"
    using q' nz by (metis div_mult_self2_is_id poly_gcd_zero_iff)
  ultimately show ?thesis using div_gcd_coprime_poly[OF nz] by auto
qed

section{*Lemmas about pcompose*}

lemma degree_mult_eq_0:
  fixes p q:: "'a :: idom poly"
  shows "degree (p*q) = 0 \<longleftrightarrow> p=0 \<or> q=0 \<or> (p\<noteq>0 \<and> q\<noteq>0 \<and> degree p =0 \<and> degree q =0)"
by (auto simp add:degree_mult_eq)

lemma pcompose_const[simp]:"pcompose [:a:] q = [:a:]" by (subst pcompose_pCons,simp)

lemma pcompose_0':"pcompose p 0=[:coeff p 0:]"
  apply (induct p)
  apply (auto simp add:pcompose_pCons)
done

lemma degree_pcompose:
  fixes p q:: "'a::idom poly"
  shows "degree(pcompose p q) = degree p * degree q"
proof (induct p)
  case 0
  thus ?case by auto
next
  case (pCons a p)
  have "degree (q * pcompose p q) = 0 \<Longrightarrow> ?case"
    proof (cases "p=0")
      case True
      thus ?thesis by auto
    next
      case False assume "degree (q * pcompose p q) = 0"
      hence "degree q=0 \<or> pcompose p q=0" by (auto simp add:degree_mult_eq_0)
      moreover have "\<lbrakk>pcompose p q=0;degree q\<noteq>0\<rbrakk> \<Longrightarrow> False" using pCons.hyps(2) `p\<noteq>0`
        proof -
          assume "pcompose p q=0" "degree q\<noteq>0"
          hence "degree p=0" using pCons.hyps(2) by auto
          then obtain a1 where "p=[:a1:]"
            by (metis degree_pCons_eq_if old.nat.distinct(2) pCons_cases)
          thus False using `pcompose p q=0` `p\<noteq>0` by auto
        qed
      ultimately have "degree (pCons a p) * degree q=0" by auto
      moreover have "degree (pcompose (pCons a p) q) = 0"
        proof -
          have" 0 = max (degree [:a:]) (degree (q*pcompose p q))"
            using `degree (q * pcompose p q) = 0` by simp
          also have "... \<ge> degree ([:a:] + q * pcompose p q)"
            by (rule degree_add_le_max)
          finally show ?thesis by (auto simp add:pcompose_pCons)
        qed
      ultimately show ?thesis by simp
    qed
  moreover have "degree (q * pcompose p q)>0 \<Longrightarrow> ?case"
    proof -
      assume asm:"0 < degree (q * pcompose p q)"
      hence "p\<noteq>0" "q\<noteq>0" "pcompose p q\<noteq>0" by auto
      have "degree (pcompose (pCons a p) q) = degree ( q * pcompose p q)"
        unfolding pcompose_pCons
        using degree_add_eq_right[of "[:a:]" ] asm by auto
      thus ?thesis
        using pCons.hyps(2) degree_mult_eq[OF `q\<noteq>0` `pcompose p q\<noteq>0`] by auto
    qed
  ultimately show ?case by blast
qed

lemma pcompose_eq_0:
  fixes p q:: "'a::idom poly"
  assumes "pcompose p q=0" "degree q>0"
  shows "p=0"
proof -
  have "degree p=0" using assms degree_pcompose[of p q] by auto
  then obtain a where "p=[:a:]"
    by (metis degree_pCons_eq_if gr0_conv_Suc neq0_conv pCons_cases)
  hence "a=0" using assms(1) by auto
  thus ?thesis using `p=[:a:]` by simp
qed

lemma lead_coeff_pCons[simp]:
    "p\<noteq>0 \<Longrightarrow>lead_coeff (pCons a p) = lead_coeff p"
    "p=0 \<Longrightarrow> lead_coeff (pCons a p) = a"
unfolding lead_coeff_def by auto

lemma lead_coeff_0[simp]:"lead_coeff 0 =0"
  unfolding lead_coeff_def by auto

lemma lead_coeff_mult:
   fixes p q::"'a ::idom poly"
   shows "lead_coeff (p * q) = lead_coeff p * lead_coeff q"
by (unfold lead_coeff_def,cases "p=0 \<or> q=0",auto simp add:coeff_mult_degree_sum degree_mult_eq)

lemma lead_coeff_add_le:
  assumes "degree p < degree q"
  shows "lead_coeff (p+q) = lead_coeff q"
using assms unfolding lead_coeff_def
by (metis coeff_add coeff_eq_0 comm_monoid_add_class.add.left_neutral degree_add_eq_right)

lemma lead_coeff_minus:
  "lead_coeff (-p) = - lead_coeff p"
by (metis coeff_minus degree_minus lead_coeff_def)

lemma lead_coeff_comp:
  fixes p q:: "'a::idom poly"
  assumes "degree q > 0"
  shows "lead_coeff (pcompose p q) = lead_coeff p * lead_coeff q ^ (degree p)"
proof (induct p)
  case 0
  thus ?case unfolding lead_coeff_def by auto
next
  case (pCons a p)
  have "degree ( q * pcompose p q) = 0 \<Longrightarrow> ?case"
    proof -
      assume "degree ( q * pcompose p q) = 0"
      hence "pcompose p q = 0" by (metis assms degree_0 degree_mult_eq_0 neq0_conv)
      hence "p=0" using pcompose_eq_0[OF _ `degree q > 0`] by simp
      thus ?thesis by auto
    qed
  moreover have "degree ( q * pcompose p q) > 0 \<Longrightarrow> ?case"
    proof -
      assume "degree ( q * pcompose p q) > 0"
      hence "lead_coeff (pcompose (pCons a p) q) =lead_coeff ( q * pcompose p q)"
        by (auto simp add:pcompose_pCons lead_coeff_add_le)
      also have "... = lead_coeff q * (lead_coeff p * lead_coeff q ^ degree p)"
        using pCons.hyps(2) lead_coeff_mult[of q "pcompose p q"] by simp
      also have "... = lead_coeff p * lead_coeff q ^ (degree p + 1)"
        by auto
      finally show ?thesis by auto
    qed
  ultimately show ?case by blast
qed

section{*Bound of polynomials*}

definition sgn_pos_inf :: "('a::real_normed_vector) poly \<Rightarrow> 'a" where
  "sgn_pos_inf p \<equiv> sgn (lead_coeff p)"
definition sgn_neg_inf :: "('a::real_normed_vector) poly \<Rightarrow> 'a" where
  "sgn_neg_inf p \<equiv> if even (degree p) then sgn (lead_coeff p) else -sgn (lead_coeff p)"

lemma sgn_inf_sym:
  fixes p::"real poly"
  shows "sgn_pos_inf (pcompose p [:0,-1:]) = sgn_neg_inf p" (is "?L=?R")
proof -
  have "?L= sgn (lead_coeff p * (- 1) ^ degree p)"
    unfolding sgn_pos_inf_def by (subst lead_coeff_comp,unfold lead_coeff_def,auto)
  thus ?thesis unfolding sgn_neg_inf_def
    by (metis mult.right_neutral mult_minus1_right neg_one_even_power neg_one_odd_power sgn_minus)
qed

lemma poly_pinfty_gt_lc:
  fixes p:: "real poly"
  assumes  "lead_coeff p > 0"
  shows "\<exists> n. \<forall> x \<ge> n. poly p x \<ge> lead_coeff p" using assms
proof (induct p)
  case 0
  thus ?case by auto
next
  case (pCons a p)
  have "\<lbrakk>a\<noteq>0;p=0\<rbrakk> \<Longrightarrow> ?case" by auto
  moreover have "p\<noteq>0 \<Longrightarrow> ?case"
    proof -
      assume "p\<noteq>0"
      then obtain n1 where gte_lcoeff:"\<forall>x\<ge>n1. lead_coeff p \<le> poly p x" using that pCons by auto
      have gt_0:"lead_coeff p >0" using pCons(3) `p\<noteq>0` by auto
      def n\<equiv>"max n1 (1+ \<bar>a\<bar>/(lead_coeff p))"
      show ?thesis
        proof (rule_tac x=n in exI,rule,rule)
          fix x assume "n \<le> x"
          hence "lead_coeff p \<le> poly p x"
            using gte_lcoeff unfolding n_def by auto
          hence " \<bar>a\<bar>/(lead_coeff p) \<ge> \<bar>a\<bar>/(poly p x)" and "poly p x>0" using gt_0
            by (intro frac_le,auto)
          hence "x\<ge>1+ \<bar>a\<bar>/(poly p x)" using `n\<le>x`[unfolded n_def] by auto
          thus "lead_coeff (pCons a p) \<le> poly (pCons a p) x"
            using `lead_coeff p \<le> poly p x` `poly p x>0` `p\<noteq>0`
            by (auto simp add:field_simps)
        qed
    qed
  ultimately show ?case by fastforce
qed

lemma poly_sgn_eventually_at_top:
  fixes p::"real poly"
  shows "eventually (\<lambda>x. sgn (poly p x) = sgn_pos_inf p) at_top"
proof (cases "p=0")
  case True
  thus ?thesis unfolding sgn_pos_inf_def by auto
next
  case False
  obtain ub where ub:"\<forall>x\<ge>ub. sgn (poly p x) = sgn_pos_inf p"
    proof (cases "lead_coeff p>0")
      case True
      thus ?thesis
        using that poly_pinfty_gt_lc[of p] unfolding sgn_pos_inf_def by fastforce
    next
      case False
      hence "lead_coeff (-p) > 0" and "lead_coeff p < 0" unfolding lead_coeff_minus
        using leading_coeff_neq_0[OF `p\<noteq>0`,folded lead_coeff_def] by auto
      then obtain n where "\<forall>x\<ge>n. lead_coeff p \<ge> poly p x"
        using poly_pinfty_gt_lc[of "-p"] unfolding lead_coeff_minus by auto
      thus ?thesis using `lead_coeff p<0` that[of n] unfolding sgn_pos_inf_def by fastforce
    qed
  thus ?thesis unfolding eventually_at_top_linorder by auto
qed

lemma poly_sgn_eventually_at_bot:
  fixes p::"real poly"
  shows "eventually (\<lambda>x. sgn (poly p x) = sgn_neg_inf p) at_bot"
using
  poly_sgn_eventually_at_top[of "pcompose p [:0,-1:]",unfolded poly_pcompose sgn_inf_sym,simplified]
  eventually_filtermap[of _ uminus "at_bot::real filter",folded at_top_mirror]
by auto

lemma root_ub:
  fixes p:: "real poly"
  assumes "p\<noteq>0"
  obtains ub where "\<forall>x. poly p x=0 \<longrightarrow> x<ub"
    and "\<forall>x\<ge>ub. sgn (poly p x) = sgn_pos_inf p"
proof -
  obtain ub1 where ub1:"\<forall>x. poly p x=0 \<longrightarrow> x<ub1"
    proof (cases "\<exists> r. poly p r=0")
      case False
      thus ?thesis using that by auto
    next
      case True
      def max_r\<equiv>"Max {x . poly p x=0}"
      hence "\<forall>x. poly p x=0 \<longrightarrow> x\<le>max_r"
        using  poly_roots_finite[OF `p\<noteq>0`] True by auto
      thus ?thesis using that[of "max_r+1"]
        by (metis add.commute add_strict_increasing zero_less_one)
    qed
  obtain ub2 where ub2:"\<forall>x\<ge>ub2. sgn (poly p x) = sgn_pos_inf p"
    using poly_sgn_eventually_at_top[unfolded eventually_at_top_linorder] by auto
  def ub\<equiv>"max ub1 ub2"
  have "\<forall>x. poly p x=0 \<longrightarrow> x<ub" using ub1 ub_def
    by (metis eq_iff less_eq_real_def less_linear max.bounded_iff)
  thus ?thesis using that[of ub] ub2 ub_def by auto
qed

lemma root_lb:
  fixes p:: "real poly"
  assumes "p\<noteq>0"
  obtains lb where "\<forall>x. poly p x=0 \<longrightarrow> x>lb"
    and "\<forall>x\<le>lb. sgn (poly p x) = sgn_neg_inf p"
proof -
  obtain lb1 where lb1:"\<forall>x. poly p x=0 \<longrightarrow> x>lb1"
    proof (cases "\<exists> r. poly p r=0")
      case False
      thus ?thesis using that by auto
    next
      case True
      def min_r\<equiv>"Min {x . poly p x=0}"
      hence "\<forall>x. poly p x=0 \<longrightarrow> x\<ge>min_r"
        using  poly_roots_finite[OF `p\<noteq>0`] True by auto
      thus ?thesis using that[of "min_r - 1"] by (metis lt_ex order.strict_trans2 that)
    qed
  obtain lb2 where lb2:"\<forall>x\<le>lb2. sgn (poly p x) = sgn_neg_inf p"
    using poly_sgn_eventually_at_bot[unfolded eventually_at_bot_linorder] by auto
  def lb\<equiv>"min lb1 lb2"
  have "\<forall>x. poly p x=0 \<longrightarrow> x>lb" using lb1 lb_def
    by (metis (poly_guards_query) less_not_sym min_less_iff_conj neq_iff)
  thus ?thesis using that[of lb] lb2 lb_def by auto
qed

end


(* Title:      Correctness of Path Algorithms
   Author:     Walter Guttmann, Peter Hoefner
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
               Peter Hoefner <peter at hoefner-online.de>
*)

section \<open>Correctness of Path Algorithms\<close>

text \<open>
To show that our theory of paths integrates with verification tasks, we verify the correctness of three basic path algorithms.
Algorithms at the presented level are executable and can serve prototyping purposes.
Data refinement can be carried out to move from such algorithms to more efficient programs.
The total-correctness proofs use a library developed in \<^cite>\<open>"Guttmann2018c"\<close>.
\<close>

theory Path_Algorithms

imports "HOL-Hoare.Hoare_Logic" Rooted_Paths

begin

no_notation
  trancl ("(_\<^sup>+)" [1000] 999)

class choose_singleton_point_signature =
  fixes choose_singleton :: "'a \<Rightarrow> 'a"
  fixes choose_point :: "'a \<Rightarrow> 'a"

class relation_algebra_rtc_tarski_choose_point =
  relation_algebra_rtc_tarski + choose_singleton_point_signature +
  assumes choose_singleton_singleton: "x \<noteq> 0 \<Longrightarrow> singleton (choose_singleton x)"
  assumes choose_singleton_decreasing: "choose_singleton x \<le> x"
  assumes choose_point_point: "is_vector x \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> point (choose_point x)"
  assumes choose_point_decreasing: "choose_point x \<le> x"
begin

no_notation
  composition (infixl ";" 75) and
  times (infixl "*" 70)

notation
  composition (infixl "*" 75)

subsection \<open>Construction of a path\<close>

text \<open>
Our first example is a basic greedy algorithm that constructs a path from a vertex $x$ to a different vertex $y$ of a directed acyclic graph $D$.
\<close>

abbreviation "construct_path_inv q x y D W \<equiv>
    is_acyclic D \<and> point x \<and> point y \<and> point q \<and>
    D\<^sup>\<star> * q \<le> D\<^sup>T\<^sup>\<star> * x \<and> W \<le> D \<and> terminating_path W \<and>
    (W = 0 \<longleftrightarrow> q=y) \<and> (W \<noteq> 0 \<longleftrightarrow> q = start_points W \<and> y = end_points W)"

abbreviation "construct_path_inv_simp q x y D W \<equiv>
    is_acyclic D \<and> point x \<and> point y \<and> point q \<and>
    D\<^sup>\<star> * q \<le> D\<^sup>T\<^sup>\<star> * x \<and> W \<le> D \<and> terminating_path W \<and>
    q = start_points W \<and> y = end_points W"

lemma construct_path_pre:
  assumes "is_acyclic D"
      and "point y"
      and "point x"
      and "D\<^sup>\<star> * y \<le> D\<^sup>T\<^sup>\<star> * x"
    shows "construct_path_inv y x y D 0"
  apply (intro conjI, simp_all add: assms is_inj_def is_p_fun_def path_def)
  using assms(2) cycle_iff by fastforce

text \<open>
The following three lemmas are auxiliary lemmas for \<open>construct_path_inv\<close>.
They are pulled out of the main proof to have more structure.
\<close>

lemma path_inv_points:
  assumes "construct_path_inv q x y D W \<and> q \<noteq> x"
  shows "point q"
    and "point (choose_point (D*q))"
 using assms apply blast
by (metis assms choose_point_point comp_assoc is_vector_def point_def reachable_implies_predecessor)

lemma path_inv_choose_point_decrease:
  assumes "construct_path_inv q x y D W \<and> q \<noteq> x"
    shows "W\<noteq>0 \<Longrightarrow> choose_point (D*q) \<le> -((W + choose_point (D*q) * q\<^sup>T)\<^sup>T*1)"
proof -
  let ?q = "choose_point (D*q)"
  let ?W = "W + ?q * q\<^sup>T"
  assume as: "W\<noteq>0"
  hence "q*W \<le> W\<^sup>+" (* "connected_root q W" *)
    by (metis assms conv_contrav conv_invol conv_iso conv_terminating_path
              forward_terminating_path_end_points_1 plus_conv point_def ss423bij
              terminating_path_iff)
  hence "?q \<cdot> W\<^sup>T*1 \<le> D*q \<cdot> W\<^sup>T\<^sup>+*q"
    using choose_point_decreasing meet_iso meet_isor inf_mono assms connected_root_iff2 by simp
  also have "... \<le> (D \<cdot> D\<^sup>T\<^sup>+)*q"
    by (metis assms inj_distr point_def conv_contrav conv_invol conv_iso meet_isor
              mult_isol_var mult_isor star_conv star_slide_var star_subdist sup.commute sup.orderE)
  also have "... \<le> 0"
    by (metis acyclic_trans assms conv_zero step_has_target order.eq_iff galois_aux ss_p18)
  finally have a: "?q \<le> -(W\<^sup>T*1)"
    using galois_aux le_bot by blast

  have "point ?q"
    using assms by(rule path_inv_points(2))
  hence "?q \<le> -(q*?q\<^sup>T*1)"
    by (metis assms acyclic_imp_one_step_different_points(2) point_is_point
            choose_point_decreasing edge_end end_point_char end_point_no_successor)
  with a show ?thesis
    by (simp add: inf.boundedI)
qed

lemma end_points:
  assumes "construct_path_inv q x y D W \<and> q \<noteq> x"
    shows "choose_point (D*q) = start_points (W + choose_point (D*q) * q\<^sup>T)"
      and "y = end_points (W + choose_point (D*q) * q\<^sup>T)"
proof -
  let ?q = "choose_point (D*q)"
  let ?W = "W + ?q * q\<^sup>T"
  show 1: "?q = start_points ?W"
  proof (rule order.antisym)
    show" start_points ?W \<le> ?q"
      by (metis assms(1) path_inv_points(2) acyclic_imp_one_step_different_points(2)
                choose_point_decreasing edge_end edge_start sup.commute
                path_concatenation_start_points_approx point_is_point order.eq_iff sup_bot_left)
    show "?q \<le> start_points ?W"
    proof -
      have a: "?q = ?q*q\<^sup>T*1"
        by (metis assms(1) comp_assoc point_equations(1) point_is_point aux4 conv_zero
                  choose_point_decreasing choose_point_point conv_contrav conv_one point_def
                  inf.orderE inf_compl_bot inf_compl_bot_right is_vector_def maddux_142
                  sup_bot_left sur_def_var1)
      hence "?q =(q \<cdot> -q) + (?q \<cdot> -q \<cdot> -(?W\<^sup>T*1))"
        by (metis assms path_inv_points(2) path_inv_choose_point_decrease
                  acyclic_imp_one_step_different_points(1) choose_point_decreasing inf.orderE
                  inf_compl_bot sup_inf_absorb edge_start point_is_point sup_bot_left)
      also have "... \<le> (W*1 \<cdot> -(?W\<^sup>T*1) \<cdot> -q) + (?q \<cdot> -q \<cdot> -(?W\<^sup>T*1))"
        by simp
      also have "... = (W*1 + ?q) \<cdot> -(q + ?W\<^sup>T*1)"
        by (metis compl_sup inf_sup_distrib2 meet_assoc sup.commute)
      also have "... \<le> ?W*1 \<cdot> -(?W\<^sup>T*1)"
        using a by (metis inf.left_commute distrib_right' compl_sup inf.cobounded2)
      finally show "?q \<le> start_points ?W" .
    qed
  qed
  show "y = end_points ?W"
  proof -
    have point_nq: "point ?q"
      using assms by(rule path_inv_points(2))
    hence yp: "y \<le> -?q"
      using 1 assms
      by (metis acyclic_imp_one_step_different_points(2) choose_point_decreasing cycle_no_points(1)
                finite_iff finite_iff_msc forward_finite_iff_msc path_aux1a path_edge_equals_cycle
                point_is_point point_not_equal(1) terminating_iff1)
    have "y = y + (W*1 \<cdot> -(W\<^sup>T*1) \<cdot> -(W*1))"
      by (simp add: inf.commute)
    also have "... = y + (q \<cdot> -(W*1))"
      using assms by fastforce
    also have "... = y + (q \<cdot> -(W*1) \<cdot> -?q)"
      by (metis calculation sup_assoc sup_inf_absorb)
    also have "... = (y \<cdot> -?q) + (q \<cdot> -(W*1) \<cdot> -?q)"
      using yp by (simp add: inf.absorb1)
    also have "... = (W\<^sup>T*1 \<cdot> -(W*1) \<cdot> -?q) + (q \<cdot> -(W*1) \<cdot> -?q)"
      using assms by fastforce
    also have "... = (W\<^sup>T*1 + q) \<cdot> -(W*1) \<cdot> -?q"
      by (simp add: inf_sup_distrib2)
    also have "... = (W\<^sup>T*1 + q) \<cdot> -(W*1 + ?q)"
      by (simp add: inf.assoc)
    also have "... = (W\<^sup>T*1 + q*?q\<^sup>T*1) \<cdot> -(W*1 + ?q*q\<^sup>T*1)"
      using point_nq
      by(metis assms(1) comp_assoc conv_contrav conv_one is_vector_def point_def sur_def_var1)
    also have "... = (?W\<^sup>T)*1 \<cdot> -(?W*1)"
      by simp
    finally show ?thesis .
  qed
qed

lemma construct_path_inv:
  assumes "construct_path_inv q x y D W \<and> q \<noteq> x"
  shows "construct_path_inv (choose_point (D*q)) x y D (W + choose_point (D*q)*q\<^sup>T)"
proof (intro conjI)
  let ?q = "choose_point (D*q)"
  let ?W = "W + ?q * q\<^sup>T"
  show "is_acyclic D"
    using assms by blast
  show point_y: "point y"
    using assms by blast
  show "point x"
    using assms by blast
  show "?W \<le> D"
    using assms choose_point_decreasing le_sup_iff point_def ss423bij inf.boundedE by blast
  show "D\<^sup>\<star>*?q \<le> D\<^sup>T\<^sup>\<star>*x"
  proof -
    have "D\<^sup>+*q \<le> D\<^sup>T\<^sup>\<star>*x"
      using assms conv_galois_2 order_trans star_1l by blast
    thus ?thesis
      by (metis choose_point_decreasing comp_assoc dual_order.trans mult_isol star_slide_var)
  qed
  show point_nq: "point ?q"
    using assms by(rule path_inv_points(2))
  show pathW: "path ?W"
    proof(cases "W=0")
      assume "W=0"
      thus ?thesis
        using assms edge_is_path point_is_point point_nq by simp
    next
      assume a: "W\<noteq>0"
      have b: "?q*q\<^sup>T \<le> 1*?q*q\<^sup>T*-(?q*q\<^sup>T*1)"
      proof -
        have "?q*q\<^sup>T \<le>1" by simp
        thus ?thesis
          using assms point_nq
          by(metis different_points_consequences(1) point_def sur_def_var1
               acyclic_imp_one_step_different_points(2) choose_point_decreasing comp_assoc
               is_vector_def point_def point_equations(3,4) point_is_point)
      qed
      have c: "W \<le> -(1*W)*W*1"
        using assms terminating_path_iff by blast
      have d: "(?q*q\<^sup>T)\<^sup>T*1 \<cdot> -((?q*q\<^sup>T)*1) = W*1 \<cdot> -(W\<^sup>T*1)"
        using a
        by (metis assms path_inv_points(2) acyclic_reachable_points choose_point_decreasing
                  edge_end point_is_point comp_assoc point_def sur_total total_one)
      have e: "?q*q\<^sup>T*1 \<cdot> W\<^sup>T*1 = 0"
      proof -
        have "?q*q\<^sup>T*1 \<cdot> W\<^sup>T*1 = ?q \<cdot> W\<^sup>T*1"
          using assms point_nq
          by (metis comp_assoc conv_contrav conv_one is_vector_def point_def sur_def_var1)
        also have "... \<le> -(?W\<^sup>T*1) \<cdot> ?W\<^sup>T*1"
          using assms path_inv_choose_point_decrease
          by (smt a conv_contrav conv_iso conv_one inf_mono less_eq_def subdistl_eq)
        also have "... \<le> 0"
          using compl_inf_bot eq_refl by blast
        finally show ?thesis
          using bot_unique by blast
      qed
      show ?thesis
      using b c d e by (metis assms comp_assoc edge_is_path path_concatenation_cycle_free
                                point_is_point sup.commute point_nq)
  qed
  show "?W = 0 \<longleftrightarrow> ?q = y"
    apply (rule iffI)
    apply (metis assms conv_zero dist_alt edge_start inf_compl_bot_right modular_1_aux' modular_2_aux'
              point_is_point sup.left_idem sup_bot_left point_nq)
    by (smt assms end_points(1) conv_contrav conv_invol cycle_no_points(1) end_point_iff2 has_start_end_points_iff path_aux1b path_edge_equals_cycle point_is_point start_point_iff2 sup_bot_left top_greatest pathW)
  show "?W\<noteq>0 \<longleftrightarrow> ?q = start_points ?W \<and> y = end_points ?W"
    apply (rule iffI)
    using assms end_points apply blast
    using assms by force
  show "terminating ?W"
    by (smt assms end_points end_point_iff2 has_start_end_points_iff point_is_point start_point_iff2
            terminating_iff1 pathW point_nq)
qed

theorem construct_path_partial: "VARS p q W
  { is_acyclic D \<and> point y \<and> point x \<and> D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x }
  W := 0;
  q := y;
  WHILE q \<noteq> x
    INV { construct_path_inv q x y D W }
     DO p := choose_point (D*q);
        W := W + p*q\<^sup>T;
        q := p
     OD
  { W \<le> D \<and> terminating_path W \<and> (W=0 \<longleftrightarrow> x=y) \<and> (W\<noteq>0 \<longleftrightarrow> x = start_points W \<and> y = end_points W) }"
  apply vcg
  using construct_path_pre apply blast
  using construct_path_inv apply blast
  by fastforce

end (* relation_algebra_rtc_tarski_choose_point *)

text \<open>For termination, we additionally need finiteness.\<close>

context finite
begin

lemma decrease_set:
  assumes "\<forall>x::'a . Q x \<longrightarrow> P x"
      and "P w"
      and "\<not> Q w"
    shows "card { x . Q x } < card { x . P x }"
by (metis Collect_mono assms card_seteq finite mem_Collect_eq not_le)

end

class relation_algebra_rtc_tarski_choose_point_finite =
      relation_algebra_rtc_tarski_choose_point + relation_algebra_rtc_tarski_point_finite
begin

lemma decrease_variant:
  assumes "y \<le> z"
      and "w \<le> z"
      and "\<not> w \<le> y"
    shows "card { x . x \<le> y } < card { x . x \<le> z }"
by (metis Collect_mono assms card_seteq linorder_not_le dual_order.trans finite_code mem_Collect_eq)

lemma construct_path_inv_termination:
  assumes "construct_path_inv q x y D W \<and> q \<noteq> x"
    shows "card { z . z \<le> -(W + choose_point (D*q)*q\<^sup>T) } < card { z . z \<le> -W }"
proof -
  let ?q = "choose_point (D*q)"
  let ?W = "W + ?q * q\<^sup>T"
  show ?thesis
  proof (rule decrease_variant)
    show "-?W \<le> -W"
      by simp
    show "?q * q\<^sup>T \<le> -W"
      by (metis assms galois_aux inf_compl_bot_right maddux_142 mult_isor order_trans top_greatest)
    show "\<not> (?q * q\<^sup>T \<le> -?W)"
      using assms end_points(1)
      by (smt acyclic_imp_one_step_different_points(2) choose_point_decreasing compl_sup inf.absorb1
              inf_compl_bot_right sup.commute sup_bot.left_neutral conv_zero end_points(2))
  qed
qed

theorem construct_path_total: "VARS p q W
  [ is_acyclic D \<and> point y \<and> point x \<and> D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x ]
  W := 0;
  q := y;
  WHILE q \<noteq> x
    INV { construct_path_inv q x y D W }
    VAR { card { z . z \<le> -W } }
     DO p := choose_point (D*q);
        W := W + p*q\<^sup>T;
        q := p
     OD
  [ W \<le> D \<and> terminating_path W \<and> (W=0 \<longleftrightarrow> x=y) \<and> (W\<noteq>0 \<longleftrightarrow> x = start_points W \<and> y = end_points W) ]"
  apply vcg_tc
  using construct_path_pre apply blast
  apply (rule CollectI, rule conjI)
  using construct_path_inv apply blast
  using construct_path_inv_termination apply clarsimp
  by fastforce

end (* relation_algebra_rtc_tarski_choose_point_finite *)

subsection \<open>Topological sorting\<close>

text \<open>
In our second example we look at topological sorting.
Given a directed acyclic graph, the problem is to construct a linear order of its vertices that contains $x$ before $y$ for each edge $(x,y)$ of the graph.
If the input graph models dependencies between tasks, the output is a linear schedule of the tasks that respects all dependencies.
\<close>

context relation_algebra_rtc_tarski_choose_point
begin

abbreviation topological_sort_inv
  where "topological_sort_inv q v R W \<equiv>
         regressively_finite R \<and> R \<cdot> v*v\<^sup>T \<le> W\<^sup>+ \<and> terminating_path W \<and> W*1 = v\<cdot>-q \<and>
         (W = 0 \<or> q = end_points W) \<and> point q \<and> R*v \<le> v \<and> q \<le> v \<and> is_vector v"

lemma topological_sort_pre:
  assumes "regressively_finite R"
  shows "topological_sort_inv (choose_point (minimum R 1)) (choose_point (minimum R 1)) R 0"
proof (intro conjI,simp_all add:assms)
  let ?q = "choose_point (- (R\<^sup>T * 1))"
  show point_q: "point ?q"
    using assms by (metis (full_types) annir choose_point_point galois_aux2 is_inj_def is_sur_def
                          is_vector_def one_idem_mult point_def ss_p18 inf_top_left one_compl)
  show "R \<cdot> ?q * ?q\<^sup>T \<le> 0"
    by (metis choose_point_decreasing conv_invol end_point_char order.eq_iff inf_bot_left schroeder_2)
  show "path 0"
    by (simp add: is_inj_def is_p_fun_def path_def)
  show "R*?q \<le> ?q"
    by (metis choose_point_decreasing compl_bot_eq conv_galois_1 inf_compl_bot_left2 le_inf_iff)
  show "is_vector ?q"
    using point_q point_def by blast
qed

lemma topological_sort_inv:
  assumes "v \<noteq> 1"
      and "topological_sort_inv q v R W"
    shows "topological_sort_inv (choose_point (minimum R (- v))) (v +
                      choose_point (minimum R (- v))) R (W + q * choose_point (minimum R (- v))\<^sup>T)"
proof (intro conjI)
  let ?p = "choose_point (minimum R (-v))"
  let ?W = "W + q*?p\<^sup>T"
  let ?v = "v + ?p"
  show point_p: "point ?p"
    using assms
    by (metis choose_point_point compl_bot_eq double_compl galois_aux2 comp_assoc is_vector_def
              vector_compl vector_mult)
  hence ep_np: "end_points (q*?p\<^sup>T) = ?p"
    using assms(2)
    by (metis aux4 choose_point_decreasing edge_end le_supI1 point_in_vector_or_complement_iff
              point_is_point)
  hence sp_q: "start_points (q*?p\<^sup>T) = q"
    using assms(2) point_p
    by (metis (no_types, lifting) conv_contrav conv_invol edge_start point_is_point)
  hence ep_sp: "W \<noteq> 0 \<Longrightarrow> end_points W = start_points (q*?p\<^sup>T)"
    using assms(2) by force
  have "W*1 \<cdot> (q*?p\<^sup>T)\<^sup>T*1 = v\<cdot>-q\<cdot>?p"
    using assms(2) point_p is_vector_def mult_assoc point_def point_equations(3) point_is_point
    by auto
  hence 1: "W*1 \<cdot> (q*?p\<^sup>T)\<^sup>T*1 = 0"
    by (metis choose_point_decreasing dual_order.trans galois_aux inf.cobounded2 inf.commute)

  show "regressively_finite R"
    using assms(2) by blast
  show "R \<cdot> ?v*?v\<^sup>T \<le> ?W\<^sup>+"
  proof -
    have a: "R \<cdot> v*v\<^sup>T \<le> ?W\<^sup>+"
      using assms(2) by (meson mult_isol_var order.trans order_prop star_subdist)
    have b: "R \<cdot> v*?p\<^sup>T \<le> ?W\<^sup>+"
    proof -
      have "R \<cdot> v*?p\<^sup>T \<le> W*1*?p\<^sup>T + q*?p\<^sup>T"
        by (metis inf_le2 assms(2) aux4 double_compl inf_absorb2 distrib_right)
      also have "... = W*?p\<^sup>T + q*?p\<^sup>T"
        using point_p by (metis conv_contrav conv_one is_vector_def mult_assoc point_def)
      also have "... \<le> W\<^sup>+*end_points W*?p\<^sup>T + q*?p\<^sup>T"
        using assms(2)
        by (meson forward_terminating_path_end_points_1 join_iso mult_isor terminating_path_iff)
      also have "... \<le> W\<^sup>+*q*?p\<^sup>T + q*?p\<^sup>T"
        using assms(2) by (metis annil eq_refl)
      also have "... = W\<^sup>\<star>*q*?p\<^sup>T"
        using conway.dagger_unfoldl_distr mult_assoc sup_commute by fastforce
      also have "... \<le> ?W\<^sup>+"
        by (metis mult_assoc mult_isol_var star_slide_var star_subdist sup_ge2)
      finally show ?thesis .
    qed
    have c: "R \<cdot> ?p*v\<^sup>T \<le> ?W\<^sup>+"
    proof -
      have "v \<le> -?p"
        using choose_point_decreasing compl_le_swap1 inf_le1 order_trans by blast
      hence "R*v \<le> -?p"
        using assms(2) order.trans by blast
      thus ?thesis
        by (metis galois_aux inf_le2 schroeder_2)
    qed
    have d: "R \<cdot> ?p*?p\<^sup>T \<le> ?W\<^sup>+"
    proof -
      have "R \<cdot> ?p*?p\<^sup>T \<le> R \<cdot> 1'"
        using point_p is_inj_def meet_isor point_def by blast
      also have "... = 0"
        using assms(2) regressively_finite_irreflexive galois_aux by blast
      finally show ?thesis
        using bot_least inf.absorb_iff2 by simp
    qed
    have "R \<cdot> ?v*?v\<^sup>T = (R \<cdot> v*v\<^sup>T) + (R \<cdot> v*?p\<^sup>T) + (R \<cdot> ?p*v\<^sup>T) + (R \<cdot> ?p*?p\<^sup>T)"
      by (metis conv_add distrib_left distrib_right inf_sup_distrib1 sup.commute sup.left_commute)
    also have "... \<le> ?W\<^sup>+"
      using a b c d by (simp add: le_sup_iff)
    finally show ?thesis .
  qed
  show pathW: "path ?W"
  proof (cases "W = 0")
    assume "W = 0"
    thus ?thesis
      using assms(2) point_p edge_is_path point_is_point sup_bot_left by auto
  next
    assume a1: "W \<noteq> 0"
    have fw_path: "forward_terminating_path W"
      using assms(2) terminating_iff by blast
    have bw_path: "backward_terminating_path (q*?p\<^sup>T)"
      using assms point_p sp_q
      by (metis conv_backward_terminating conv_has_start_points conv_path edge_is_path
                forward_terminating_iff1 point_is_point start_point_iff2)
    show ?thesis
      using fw_path bw_path ep_sp 1 a1 path_concatenation_cycle_free by blast
  qed
  show "terminating ?W"
  proof (rule start_end_implies_terminating)
    show "has_start_points ?W"
      apply (cases "W = 0")
      using assms(2) sp_q pathW
      apply (metis (no_types, lifting) point_is_point start_point_iff2 sup_bot.left_neutral)
      using assms(2) ep_sp 1 pathW
      by (metis has_start_end_points_iff path_concatenation_start_points start_point_iff2
                terminating_iff1)
    show "has_end_points ?W"
      apply (cases "W = 0")
      using point_p ep_np ep_sp pathW end_point_iff2 point_is_point apply force
      using point_p ep_np ep_sp 1 pathW
      by (metis end_point_iff2 path_concatenation_end_points point_is_point)
  qed
  show "?W*1 = ?v\<cdot>-?p"
  proof -
    have "?W*1 = v"
      by (metis assms(2) point_p is_vector_def mult_assoc point_def point_equations(3)
                point_is_point aux4 distrib_right' inf_absorb2 sup.commute)
    also have "... = v\<cdot>-?p"
      by (metis choose_point_decreasing compl_le_swap1 inf.cobounded1 inf.orderE order_trans)
    finally show ?thesis
      by (simp add: inf_sup_distrib2)
  qed
  show "?W = 0 \<or> ?p = end_points ?W"
    using ep_np ep_sp 1 by (metis path_concatenation_end_points sup_bot_left)
  show "R*?v \<le> ?v"
    using assms(2)
    by (meson choose_point_decreasing conv_galois_1 inf.cobounded2 order.trans sup.coboundedI1
              sup_least)
  show "?p \<le> ?v"
    by simp
  show "is_vector ?v"
    using assms(2) point_p point_def vector_add by blast
qed

lemma topological_sort_post:
 assumes "\<not> v \<noteq> 1"
     and "topological_sort_inv q v R W"
   shows "R \<le> W\<^sup>+ \<and> terminating_path W \<and> (W + W\<^sup>T)*1 = -1'*1"
proof (intro conjI,simp_all add:assms)
  show "R \<le> W\<^sup>+"
    using assms by force
  show " backward_terminating W \<and> W \<le> 1 * W * (- v + q)"
    using assms by force
  show "v \<cdot> - q + W\<^sup>T * 1 = - 1' * 1"
    proof (cases "W = 0")
      assume "W = 0"
      thus ?thesis
        using assms
        by (metis compl_bot_eq conv_one conv_zero double_compl inf_top.left_neutral is_inj_def
                  le_bot mult_1_right one_idem_mult point_def ss_p18 star_zero sup.absorb2 top_le)
    next
      assume a1: "W \<noteq> 0"
      hence "-1' \<noteq> 0"
        using assms backward_terminating_path_irreflexive le_bot by fastforce
      hence "1 = 1*-1'*1"
        by (simp add: tarski)
      also have "... = -1'*1"
        by (metis comp_assoc distrib_left mult_1_left sup_top_left distrib_right sup_compl_top)
      finally have a: "1 = -1'*1" .
      have "W*1 + W\<^sup>T*1 = 1"
        using assms a1 by (metis double_compl galois_aux4 inf.absorb_iff2 inf_top.left_neutral)
      thus ?thesis
        using a by (simp add: assms(2))
    qed
qed

theorem topological_sort_partial: "VARS p q v W
  { regressively_finite R }
  W := 0;
  q := choose_point (minimum R 1);
  v := q;
  WHILE v \<noteq> 1
    INV { topological_sort_inv q v R W }
     DO p := choose_point (minimum R (-v));
        W := W + q*p\<^sup>T;
        q := p;
        v := v + p
     OD
  { R \<le> W\<^sup>+ \<and> terminating_path W \<and> (W + W\<^sup>T)*1 = -1'*1 }"
  apply vcg
  using topological_sort_pre apply blast
  using topological_sort_inv apply blast
  using topological_sort_post by blast

end (* relation_algebra_rtc_tarski_choose_point *)

context relation_algebra_rtc_tarski_choose_point_finite
begin

lemma topological_sort_inv_termination:
  assumes "v \<noteq> 1"
      and "topological_sort_inv q v R W"
    shows "card {z . z \<le> -(v + choose_point (minimum R (-v)))} < card { z . z \<le> -v }"
proof (rule decrease_variant)
  let ?p = "choose_point (minimum R (-v))"
  let ?v = "v + ?p"
  show "-?v \<le> -v"
    by simp
  show "?p \<le> -v"
    using choose_point_decreasing inf.boundedE by blast
  have "point ?p"
    using assms
    by (metis choose_point_point compl_bot_eq double_compl galois_aux2 comp_assoc is_vector_def
              vector_compl vector_mult)
  thus "\<not> (?p \<le> -?v)"
    by (metis annir compl_sup inf.absorb1 inf_compl_bot_right maddux_20 no_end_point_char)
qed

text \<open>
Use precondition \<open>is_acyclic\<close> instead of \<open>regressively_finite\<close>.
They are equivalent for finite graphs.
\<close>

theorem topological_sort_total: "VARS p q v W
  [ is_acyclic R ]
  W := 0;
  q := choose_point (minimum R 1);
  v := q;
  WHILE v \<noteq> 1
    INV { topological_sort_inv q v R W }
    VAR { card { z . z \<le> -v } }
      DO p := choose_point (minimum R (-v));
         W := W + q*p\<^sup>T;
         q := p;
         v := v + p
      OD
   [ R \<le> W\<^sup>+ \<and> terminating_path W \<and> (W + W\<^sup>T)*1 = -1'*1 ]"
  apply vcg_tc
  apply (drule acyclic_regressively_finite)
  using topological_sort_pre apply blast
  apply (rule CollectI, rule conjI)
  using topological_sort_inv apply blast
  using topological_sort_inv_termination apply auto[1]
  using topological_sort_post by blast

end (* relation_algebra_rtc_tarski_choose_point_finite *)

subsection \<open>Construction of a tree\<close>

text \<open>
Our last application is a correctness proof of an algorithm that constructs a non-empty cycle for a given directed graph.
This works in two steps.
The first step is to construct a directed tree from a given root along the edges of the graph.
\<close>

context relation_algebra_rtc_tarski_choose_point
begin

abbreviation construct_tree_pre
  where "construct_tree_pre x y R \<equiv> y \<le> R\<^sup>T\<^sup>\<star>*x \<and> point x"
abbreviation construct_tree_inv
  where "construct_tree_inv v x y D R \<equiv> construct_tree_pre x y R \<and> is_acyclic D \<and> is_inj D \<and>
                                         D \<le> R \<and> D*x = 0 \<and> v = x + D\<^sup>T*1 \<and> x*v\<^sup>T \<le> D\<^sup>\<star> \<and> D \<le> v*v\<^sup>T \<and>
                                         is_vector v"
abbreviation construct_tree_post
  where "construct_tree_post x y D R \<equiv> is_acyclic D \<and> is_inj D \<and> D \<le> R \<and> D*x = 0 \<and> D\<^sup>T*1 \<le> D\<^sup>T\<^sup>\<star>*x \<and>
                                        D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x"

lemma construct_tree_pre:
  assumes "construct_tree_pre x y R"
    shows "construct_tree_inv x x y 0 R"
using assms by (simp add: is_inj_def point_def)

lemma construct_tree_inv_aux:
  assumes "\<not> y \<le> v"
      and "construct_tree_inv v x y D R"
    shows "singleton (choose_singleton (v*-v\<^sup>T \<cdot> R))"
proof (rule choose_singleton_singleton, rule notI)
  assume "v*-v\<^sup>T \<cdot> R = 0"
  hence "R\<^sup>T\<^sup>\<star>*v \<le> v"
    by (metis galois_aux conv_compl conv_galois_1 conv_galois_2 conv_invol double_compl
              star_inductl_var)
  hence "y = 0"
    using assms by (meson mult_isol order_trans sup.cobounded1)
  thus False
   using assms point_is_point by auto
qed

lemma construct_tree_inv:
  assumes "\<not> y \<le> v"
      and "construct_tree_inv v x y D R"
    shows "construct_tree_inv (v + choose_singleton (v*-v\<^sup>T \<cdot> R)\<^sup>T*1) x y (D +
                               choose_singleton (v*-v\<^sup>T \<cdot> R)) R"
proof (intro conjI)
  let ?e = "choose_singleton (v*-v\<^sup>T \<cdot> R)"
  let ?D = "D + ?e"
  let ?v = "v + ?e\<^sup>T*1"
  have 1: "?e \<le> v*-v\<^sup>T"
    using choose_singleton_decreasing inf.boundedE by blast
  show "point x"
    by (simp add: assms)
  show "y \<le> R\<^sup>T\<^sup>\<star>*x"
    by (simp add: assms)
  show "is_acyclic ?D"
    using 1 assms acyclic_inv by fastforce
  show "is_inj ?D"
    using 1 construct_tree_inv_aux assms injective_inv by blast
  show "?D \<le> R"
    apply (rule sup.boundedI)
    using assms apply blast
    using choose_singleton_decreasing inf.boundedE by blast
  show "?D*x = 0"
  proof -
    have "?D*x = ?e*x"
      by (simp add: assms)
    also have "... \<le> ?e*v"
      by (simp add: assms mult_isol)
    also have "... \<le> v*-v\<^sup>T*v"
      using 1 mult_isor by blast
    also have "... = 0"
      by (metis assms(2) annir comp_assoc vector_prop1)
    finally show ?thesis
      using le_bot by blast
  qed
  show "?v = x + ?D\<^sup>T*1"
    by (simp add: assms sup_assoc)
  show "x*?v\<^sup>T \<le> ?D\<^sup>\<star>"
  proof -
    have "x*?v\<^sup>T = x*v\<^sup>T + x*1*?e"
      by (simp add: distrib_left mult_assoc)
    also have "... \<le> D\<^sup>\<star> + x*1*(?e \<cdot> v*-v\<^sup>T)"
      using 1 by (metis assms(2) inf.absorb1 join_iso)
    also have "... = D\<^sup>\<star> + x*1*(?e \<cdot> v \<cdot> -v\<^sup>T)"
      by (metis assms(2) comp_assoc conv_compl inf.assoc vector_compl vector_meet_comp)
    also have "... \<le> D\<^sup>\<star> + x*1*(?e \<cdot> v)"
      using join_isol mult_subdistl by fastforce
    also have "... = D\<^sup>\<star> + x*(1 \<cdot> v\<^sup>T)*?e"
      by (metis assms(2) inf.commute mult_assoc vector_2)
    also have "... = D\<^sup>\<star> + x*v\<^sup>T*?e"
      by simp
    also have "... \<le> D\<^sup>\<star> + D\<^sup>\<star>*?e"
      using assms join_isol mult_isor by blast
    also have "... \<le> ?D\<^sup>\<star>"
      by (meson le_sup_iff prod_star_closure star_ext star_subdist)
    finally show ?thesis .
  qed
  show "?D \<le> ?v*?v\<^sup>T"
  proof (rule sup.boundedI)
    show "D \<le> ?v*?v\<^sup>T"
      using assms
      by (meson conv_add distrib_left le_supI1 conv_iso dual_order.trans mult_isol_var order_prop)
    have "?e \<le> v*(-v\<^sup>T \<cdot> v\<^sup>T*?e)"
      using 1 inf.absorb_iff2 modular_1' by fastforce
    also have "... \<le> v*1*?e"
      by (simp add: comp_assoc le_infI2 mult_isol_var)
    also have "... \<le> ?v*?v\<^sup>T"
      by (metis conv_contrav conv_invol conv_iso conv_one mult_assoc mult_isol_var sup.cobounded1
                sup_ge2)
    finally show "?e \<le> ?v*?v\<^sup>T"
      by simp
  qed
  show "is_vector ?v"
    using assms comp_assoc is_vector_def by fastforce
qed

lemma construct_tree_post:
  assumes "y \<le> v"
      and "construct_tree_inv v x y D R"
    shows "construct_tree_post x y D R"
proof -
  have "v*x\<^sup>T \<le> D\<^sup>T\<^sup>\<star>"
    by (metis (no_types, lifting) assms(2) conv_contrav conv_invol conv_iso star_conv)
  hence 1: "v \<le> D\<^sup>T\<^sup>\<star>*x"
    using assms point_def ss423bij by blast
  hence 2: "D\<^sup>T*1 \<le> D\<^sup>T\<^sup>\<star>*x"
    using assms le_supE by blast
  have "D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x"
  proof (rule star_inductl, rule sup.boundedI)
    show "y \<le> D\<^sup>T\<^sup>\<star>*x"
      using 1 assms order.trans by blast
  next
    have "D*(D\<^sup>T\<^sup>\<star>*x) = D*x + D*D\<^sup>T\<^sup>+*x"
      by (metis conway.dagger_unfoldl_distr distrib_left mult_assoc)
    also have "... = D*D\<^sup>T\<^sup>+*x"
      using assms by simp
    also have "... \<le> 1'*D\<^sup>T\<^sup>\<star>*x"
      by (metis assms(2) is_inj_def mult_assoc mult_isor)
    finally show "D*(D\<^sup>T\<^sup>\<star>*x) \<le> D\<^sup>T\<^sup>\<star>*x"
      by simp
  qed
  thus "construct_tree_post x y D R"
    using 2 assms by simp
qed

theorem construct_tree_partial: "VARS e v D
  { construct_tree_pre x y R }
  D := 0;
  v := x;
  WHILE \<not> y \<le> v
    INV { construct_tree_inv v x y D R }
     DO e := choose_singleton (v*-v\<^sup>T \<cdot> R);
        D := D + e;
        v := v + e\<^sup>T*1
     OD
  { construct_tree_post x y D R }"
 apply vcg
 using construct_tree_pre apply blast
 using construct_tree_inv apply blast
 using construct_tree_post by blast

end (* relation_algebra_rtc_tarski_choose_point *)

context relation_algebra_rtc_tarski_choose_point_finite
begin

lemma construct_tree_inv_termination:
 assumes " \<not> y \<le> v"
     and "construct_tree_inv v x y D R"
   shows "card { z . z \<le> -(v + choose_singleton (v*-v\<^sup>T \<cdot> R)\<^sup>T*1) } < card { z . z \<le> -v }"
proof (rule decrease_variant)
  let ?e = "choose_singleton (v*-v\<^sup>T \<cdot> R)"
  let ?v = "v + ?e\<^sup>T*1"
  have 1: "?e \<le> v*-v\<^sup>T"
    using choose_singleton_decreasing inf.boundedE by blast
  have 2: "singleton ?e"
    using construct_tree_inv_aux assms by auto
  show "-?v \<le> -v"
    by simp
  have "?e\<^sup>T \<le> -v*v\<^sup>T"
    using 1 conv_compl conv_iso by force
  also have "... \<le> -v*1"
    by (simp add: mult_isol)
  finally show "?e\<^sup>T*1 \<le> -v"
    using assms by (metis is_vector_def mult_isor one_compl)
  thus "\<not> (?e\<^sup>T*1 \<le> -?v)"
    using 2 by (metis annir compl_sup inf.absorb1 inf_compl_bot_right surj_one tarski)
qed

theorem construct_tree_total: "VARS e v D
 [ construct_tree_pre x y R ]
 D := 0;
 v := x;
 WHILE \<not> y \<le> v
   INV { construct_tree_inv v x y D R }
   VAR { card { z . z \<le> -v } }
    DO e := choose_singleton (v*-v\<^sup>T \<cdot> R);
       D := D + e;
       v := v + e\<^sup>T*1
    OD
 [ construct_tree_post x y D R ]"
  apply vcg_tc
  using construct_tree_pre apply blast
  apply (rule CollectI, rule conjI)
  using construct_tree_inv apply blast
  using construct_tree_inv_termination apply force
  using construct_tree_post by blast

end (* relation_algebra_rtc_tarski_choose_point_finite *)

subsection \<open>Construction of a non-empty cycle\<close>

text \<open>
The second step is to construct a path from the root to a given vertex in the tree.
Adding an edge back to the root gives the cycle.
\<close>

context relation_algebra_rtc_tarski_choose_point
begin

abbreviation comment
  where "comment _ \<equiv> SKIP" (* instead of inner comments *)
abbreviation construct_cycle_inv
  where "construct_cycle_inv v x y D R \<equiv> construct_tree_inv v x y D R \<and> point y \<and> y*x\<^sup>T \<le> R"

lemma construct_cycle_pre:
 assumes " \<not> is_acyclic R"
     and "y = choose_point ((R\<^sup>+ \<cdot> 1')*1)"
     and "x = choose_point (R\<^sup>\<star>*y \<cdot> R\<^sup>T*y)"
   shows "construct_cycle_inv x x y 0 R"
proof(rule conjI, rule_tac [2] conjI)
  show point_y: "point y"
    using assms by (simp add: choose_point_point is_vector_def mult_assoc galois_aux ss_p18)
  have "R\<^sup>\<star>*y \<cdot> R\<^sup>T*y \<noteq> 0"
  proof
    have "R\<^sup>+ \<cdot> 1' = (R\<^sup>+)\<^sup>T \<cdot> 1'"
      by (metis (mono_tags, opaque_lifting) conv_e conv_times inf.cobounded1 inf.commute
                many_strongly_connected_iff_6_eq mult_oner star_subid)
    also have "... = R\<^sup>T\<^sup>+ \<cdot> 1'"
      using plus_conv by fastforce
    also have "... \<le> (R\<^sup>T\<^sup>\<star> \<cdot> R)*R\<^sup>T"
      by (metis conv_contrav conv_e conv_invol modular_2_var mult_oner star_slide_var)
    also have "... \<le> (R\<^sup>T\<^sup>\<star> \<cdot> R)*1"
      by (simp add: mult_isol)
    finally have a: "(R\<^sup>+ \<cdot> 1')*1 \<le> (R\<^sup>T\<^sup>\<star> \<cdot> R)*1"
      by (metis mult_assoc mult_isor one_idem_mult)
    assume "R\<^sup>\<star>*y \<cdot> R\<^sup>T*y = 0"
    hence "(R\<^sup>\<star> \<cdot> R\<^sup>T)*y = 0"
      using point_y inj_distr point_def by blast
    hence "(R\<^sup>\<star> \<cdot> R\<^sup>T)\<^sup>T*1 \<le> -y"
      by (simp add: conv_galois_1)
    hence "y \<le> -((R\<^sup>\<star> \<cdot> R\<^sup>T)\<^sup>T*1)"
      using compl_le_swap1 by blast
    also have "... = -((R\<^sup>T\<^sup>\<star> \<cdot> R)*1)"
      by (simp add: star_conv)
    also have "... \<le> -((R\<^sup>+ \<cdot> 1')*1)"
      using a comp_anti by blast
    also have "... \<le> -y"
      by (simp add: assms galois_aux ss_p18 choose_point_decreasing)
    finally have "y = 0"
      using inf.absorb2 by fastforce
    thus False
      using point_y annir point_equations(2) point_is_point tarski by force
  qed
  hence point_x: "point x"
    by (metis point_y assms(3) inj_distr is_vector_def mult_assoc point_def choose_point_point)
  hence "y \<le> R\<^sup>T\<^sup>\<star> * x"
    by (metis assms(3) point_y choose_point_decreasing inf_le1 order.trans point_swap star_conv)
  thus tree_inv: "construct_tree_inv x x y 0 R"
    using point_x construct_tree_pre by blast
  show "y * x\<^sup>T \<le> R"
  proof -
    have "x \<le> R\<^sup>\<star>*y \<cdot> R\<^sup>T*y"
      using assms(3) choose_point_decreasing by blast
    also have "... = (R\<^sup>\<star> \<cdot> R\<^sup>T)*y"
      using point_y inj_distr point_def by fastforce
    finally have "x*y\<^sup>T \<le> R\<^sup>\<star> \<cdot> R\<^sup>T"
      using point_y point_def ss423bij by blast
    also have "... \<le> R\<^sup>T"
      by simp
    finally show ?thesis
      using conv_iso by force
  qed
qed

lemma construct_cycle_pre2:
 assumes "y \<le> v"
     and "construct_cycle_inv v x y D R"
   shows "construct_path_inv y x y D 0 \<and> D \<le> R \<and> D * x = 0 \<and> y * x\<^sup>T \<le> R"
proof(intro conjI, simp_all add: assms)
  show "D\<^sup>\<star> * y \<le> D\<^sup>T\<^sup>\<star> * x"
    using assms construct_tree_post by blast
  show "path 0"
    by (simp add: is_inj_def is_p_fun_def path_def)
  show "y \<noteq> 0"
    using assms(2) is_point_def point_is_point by blast
qed

lemma construct_cycle_post:
  assumes "\<not> q \<noteq> x"
      and "(construct_path_inv q x y D W \<and> D \<le> R \<and> D * x = 0 \<and> y * x\<^sup>T \<le> R)"
    shows "W + y * x\<^sup>T \<noteq> 0 \<and> W + y * x\<^sup>T \<le> R \<and> cycle (W + y * x\<^sup>T)"
proof(intro conjI)
  let ?C = "W + y*x\<^sup>T"
  show "?C \<noteq> 0"
    by (metis assms acyclic_imp_one_step_different_points(2) no_trivial_inverse point_def ss423bij
              sup_bot.monoid_axioms monoid.left_neutral)
  show "?C \<le> R"
    using assms(2) order_trans sup.boundedI by blast
  show "path (W + y * x\<^sup>T)"
    by (metis assms construct_tree_pre edge_is_path less_eq_def path_edge_equals_cycle
              point_is_point terminating_iff1)
  show "many_strongly_connected (W + y * x\<^sup>T)"
    by (metis assms construct_tree_pre bot_least conv_zero less_eq_def
              path_edge_equals_cycle star_conv star_subid terminating_iff1)
  qed

theorem construct_cycle_partial: "VARS e p q v x y C D W
  { \<not> is_acyclic R }
  y := choose_point ((R\<^sup>+ \<cdot> 1')*1);
  x := choose_point (R\<^sup>\<star>*y \<cdot> R\<^sup>T*y);
  D := 0;
  v := x;
  WHILE \<not> y \<le> v
    INV { construct_cycle_inv v x y D R }
     DO e := choose_singleton (v*-v\<^sup>T \<cdot> R);
        D := D + e;
        v := v + e\<^sup>T*1
     OD;
  comment { is_acyclic D \<and> point y \<and> point x \<and> D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x };
  W := 0;
  q := y;
  WHILE q \<noteq> x
    INV { construct_path_inv q x y D W \<and> D \<le> R \<and> D*x = 0 \<and> y*x\<^sup>T \<le> R }
     DO p := choose_point (D*q);
        W := W + p*q\<^sup>T;
        q := p
     OD;
  comment { W \<le> D \<and> terminating_path W \<and> (W = 0 \<longleftrightarrow> q=y) \<and> (W \<noteq> 0 \<longleftrightarrow> q = start_points W \<and> y = end_points W) };
  C := W + y*x\<^sup>T
  { C \<noteq> 0 \<and> C \<le> R \<and> cycle C }"
  apply vcg
  using construct_cycle_pre apply blast
  using construct_tree_inv apply blast
  using construct_cycle_pre2 apply blast
  using construct_path_inv apply blast
  using construct_cycle_post by blast

end (* relation_algebra_rtc_tarski_choose_point *)

context relation_algebra_rtc_tarski_choose_point_finite
begin

theorem construct_cycle_total: "VARS e p q v x y C D W
  [ \<not> is_acyclic R ]
  y := choose_point ((R\<^sup>+ \<cdot> 1')*1);
  x := choose_point (R\<^sup>\<star>*y \<cdot> R\<^sup>T*y);
  D := 0;
  v := x;
  WHILE \<not> y \<le> v
    INV { construct_cycle_inv v x y D R }
    VAR { card { z . z \<le> -v } }
     DO e := choose_singleton (v*-v\<^sup>T \<cdot> R);
        D := D + e;
        v := v + e\<^sup>T*1
     OD;
  comment { is_acyclic D \<and> point y \<and> point x \<and> D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x };
  W := 0;
  q := y;
  WHILE q \<noteq> x
    INV { construct_path_inv q x y D W \<and> D \<le> R \<and> D*x = 0 \<and> y*x\<^sup>T \<le> R }
    VAR { card { z . z \<le> -W } }
     DO p := choose_point (D*q);
        W := W + p*q\<^sup>T;
        q := p
     OD;
  comment { W \<le> D \<and> terminating_path W \<and> (W = 0 \<longleftrightarrow> q=y) \<and> (W \<noteq> 0 \<longleftrightarrow> q = start_points W \<and> y = end_points W)};
  C := W + y*x\<^sup>T
 [ C \<noteq> 0 \<and> C \<le> R \<and> cycle C ]"
  apply vcg_tc
  using construct_cycle_pre apply blast
  apply (rule CollectI, rule conjI)
  using construct_tree_inv apply blast
  using construct_tree_inv_termination apply force
  using construct_cycle_pre2 apply blast
  apply (rule CollectI, rule conjI)
  using construct_path_inv apply blast
  using construct_path_inv_termination apply clarsimp
  using construct_cycle_post by blast

end (* relation_algebra_rtc_tarski_choose_point_finite *)

end